home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 2002 November / SGI Freeware 2002 November - Disc 1.iso / dist / fw_exmh.idb / usr / freeware / lib / exmh-2.5 / mime.tcl.z / mime.tcl
Text File  |  2002-07-08  |  83KB  |  2,826 lines
  1. # mime.tcl
  2. #
  3. # MIME message display.
  4. #
  5. # Thanks to Chris Garrigues who tested and improved this code.
  6. #
  7. # Copyright (c) 1993 Xerox Corporation.
  8. # Use and copying of this software and preparation of derivative works based
  9. # upon this software are permitted. Any distribution of this software or
  10. # derivative works must comply with all applicable United States export
  11. # control laws. This software is made available AS IS, and Xerox Corporation
  12. # makes no warranty about the software, its performance or its conformity to
  13. # any specification.
  14.  
  15. proc Mime_Init {} {
  16.     global mime env base64 mimeFont
  17.  
  18.     if [info exists mime(init)] {
  19.     return
  20.     }
  21.     # Make sure Metamail is on the path
  22.     set hit 0
  23.     foreach dir [split $env(PATH) :] {
  24.     if {[string compare $dir $mime(dir)] == 0} {
  25.         set hit 1
  26.         break
  27.     }
  28.     }
  29.     if {! $hit} {
  30.     set env(PATH) $mime(dir):$env(PATH)
  31.     }
  32.     set mime(encode) mimencode
  33.     foreach dir [split $env(PATH) :] {
  34.     if {[file executable $dir/mimencode]} {
  35.         set mime(encode) mimencode
  36.         break
  37.     }
  38.     if {[file executable $dir/mmencode]} {
  39.         set mime(encode) mmencode
  40.         break
  41.     }
  42.     }
  43.  
  44.     set mime(init) 1
  45.     set mime(seed) 1
  46.     set mime(junkfiles) {}
  47.     set mime(stop) 0
  48.  
  49.     set types [concat [option get . mimeTypes {}] [option get . mimeUTypes {}]]
  50.     Exmh_Debug MimeTypes $types
  51.     set mime(showproc,default)            Mime_ShowDefault
  52.     foreach type $types {
  53.     set func [option get . mime_$type {}]
  54.     if {[string length $func] != 0} {
  55.         set mime(showproc,$type) $func
  56.     }
  57.     }
  58.  
  59.     set accessMethods [concat [option get . mimeExtMethods {}] \
  60.                   [option get . mimeUExtMethods {}]]
  61.     foreach accessMethod $accessMethods {
  62.     set func [option get . mime_$accessMethod {}]
  63.     if {[string length $func] != 0} {
  64.         set mime(accessMethod,$accessMethod) $func
  65.     }
  66.     }
  67.  
  68.     # Make a try to load Img extention, ignore failures
  69.     if [ catch { set img_version [package require Img] } ] {
  70.     Exmh_Debug Unable to load Img
  71.     } else {
  72.      Exmh_Debug Loaded Img version $img_version
  73.     }
  74.  
  75.     set imageFilters [concat [option get . imageFilters {}] \
  76.                   [option get . imageUFilters {}]]
  77.     foreach imageFilter $imageFilters {
  78.     set func [option get . image_$imageFilter {}]
  79.     if {[string length $func] != 0} {
  80.         set mime(imageFilter,$imageFilter) $func
  81.     }
  82.     }
  83.  
  84.     set fontSets {plain title fixed proportional}
  85.  
  86.     set charsets [concat [option get . mimeCharsets {}] \
  87.              [option get . mimeUCharsets {}]]
  88.     foreach charset $charsets {
  89.     set mime(registry,$charset) \
  90.         [option get . mime_${charset}_registry {}]
  91.     set mime(encoding,$charset) \
  92.         [option get . mime_${charset}_encoding {}]
  93.  
  94.     foreach fontSet $fontSets {
  95.         set families \
  96.         [option get . mime_${charset}_${fontSet}_families {}]
  97.         set i 1
  98.         foreach family $families {
  99.         set mime(family,$charset,$fontSet,$i) $family
  100.         incr i
  101.         }
  102.         set mime(family,$charset,$fontSet,$i) *
  103.     }
  104.     }
  105.  
  106.     Preferences_Add "MIME" \
  107. "MIME is the Multipurpose Internet Mail Extension that allows a variety of message types to be transfered and displayed for you." {
  108.     {mime(enabled) mimeEnabled    ON {Enable MIME display}
  109. "This controls whether or not MIME-format messages are parsed
  110. and displayed.    If it is disabled, then the messages are
  111. displayed as plain text."}
  112.     {mime(showType) mimeShowType    OFF {Show MIME types}
  113. "This controls whether or not the MIME type information for each
  114. part of a multi-part message is displayed."}
  115.     {mime(showPrelude) mimeShowPrelude    OFF {Show MIME prelude}
  116. "This controls whether or not the information between the mail headers
  117. and the official start of a multipart message is displayed.  Sometimes
  118. this has useful information, while other times it has warnings about
  119. the rest of the message being in MIME format."}
  120.     {mime(fullHeaders) mimeFullHeaders    OFF {Show full headers}
  121. "This controls whether full headers are shown for message/rfc822 items
  122. inside MIME mail.  This prevents Folder-Display and Folder-Suppress
  123. profile options from taking effect."}
  124.     {mime(maxSubpartsDisplayed) mimeMaxSubpartsDisplayed    5 
  125.         {Maximum subparts to display}
  126. "This is the maximum number of subparts to display without hiding complex
  127. subparts (multipart or message) behind an ellipsis.  Undisplayed subparts
  128. may be displayed by hand from the menu."}
  129.     {msg(maxsize) mimeMaxSize    70000
  130.         {Maximum message size before warning}
  131. "This is the maximum size of a message before exmh displays a
  132. warning about a large message and STOP button."}
  133.     {mime(ftpMethod) ftpMethod
  134.         {CHOICE expect ftp {ftp -n} metamail {URI tool}}
  135.     {FTP access method}
  136. "Sometimes the automatic FTP transfer fails because of
  137. problems logging into the remote host.    This option lets
  138. you try a few different approachs to find the one that
  139. works for you:
  140. expect - use the ftp.expect script to download the file.
  141. ftp - use ftp and feed user and password to it via a pipe.
  142. ftp -n - use the ftp no-auto-login feature.
  143. metamail - pass control to metamail and let it try.
  144. URI tool - uses your favorite WWW browser to get the
  145.            file.  See \"URI Preferences\"."}
  146.     {mime(ftpCommand) ftpCommand    ftp {FTP command name}
  147. "You may need to run a different command than \"ftp\" in
  148. order to get out onto the internet from inside your company
  149. network.  The command will be invoked with the site name as
  150. the only argument, possibly with the -n flag, which depends on
  151. your choice of the FTP access method.  If you use the expect
  152. script, you'll have to tweak that by hand."}
  153.     {mime(highlightText) highlightText ON {Highlight Message Quotes}
  154. "If enabled, this colorizes in-lined replies in messages, signatures,
  155. and other features of otherwise ordinary text messages."}
  156.     {mime(showRichCmnds) showRichCmnds OFF {Show RichText Commands}
  157. "If enabled, this allows the display of unknown richtext commands at
  158. the bottom of the richtext display.  If disabled, unknown richtext
  159. commands are simply ignored."}
  160.     {mime(showSeparator) showSeparator ON {Show Graphic Part Separator}
  161. "If enabled, MIME display uses a raised text bar to separate the
  162. header and various body parts.  Otherwise a blank line is used."}
  163.     {mime(showImage) showImage ON {Show Images}
  164. "If enabled, Image parts will be displayed immediatly when you
  165. view a message.  Otherwise you have to ask for them via the
  166. background menu."}
  167.     {mime(fontSize) mimeFontSize 120 {Default font point size}
  168. "The default point size for fonts in MIME messages.
  169. (Note: font family information is set via X resources not
  170. exposed via preferences.  Check out app-defaults."}
  171.     {mime(titleSize) mimeTitleSize 120 {Default title point size}
  172. "The default point size for part titles in MIME messages.
  173. (Note: font family information is set via X resources not
  174. exposed via preferences.  Check out app-defaults."}
  175.     {mime(noteSize) mimeNoteSize 100 {Default note point size}
  176. "The default point size for notes in MIME messages.
  177. (Note: font family information is set via X resources not
  178. exposed via preferences.  Check out app-defaults."}
  179.     {mime(eudora) mimeEudora ON {Enable Eudora attachment support}
  180. "This controls whether or not the Content-Disposition: header will be added
  181. to multipart messages so that Eudora can work out the original filename.
  182. The full header is: Content-Disposition: attachment; filename=\"...\"."}
  183.     {mime(dosname) mimeEudoraDos OFF {Map attachment name to 8.3 DOS}
  184. "This controls whether or not attachement filename
  185. will be translated into a suitable DOS 8.3 representation."}
  186.     {mime(mdnTo) dispositionNotificationTo {} {Disposition Notification To}
  187. "The address where you want MDN receipts to end up.  This normally your
  188. own email address."}
  189.     {mime(mdnSend) dispositionNotificationSend
  190.          {CHOICE never deny {ask user} auto/ask auto/ignore } 
  191.          {Send MDNs}
  192. "This controls if and how to send MDNs (receipts).  The options are:
  193.   - Never generate MDN, always ignore requests silently.
  194.   - Automatically generate a \"denied\" MDN when a MDN is requested.
  195.   - Ask user whether to generate a MDN when displaying the message.
  196.   - Automatically when displaying the message, but ask user in 
  197.     certain cases where it may not be appropriate to generate MDNs.
  198.   - As above, but silently ignore potentially suspect MDN requests."}
  199.     {mime(explainReport) explainReports OFF {Show report explanations}
  200. "This controls whether human-readable explanations are presented along
  201. with the machine-readable part (part 2) of multipart/report messages."}
  202.     }
  203.     set i 0
  204.     foreach char {A B C D E F G H I J K L M N O P Q R S T U V W X Y Z \
  205.           a b c d e f g h i j k l m n o p q r s t u v w x y z \
  206.           0 1 2 3 4 5 6 7 8 9 + /} {
  207.     set base64($char) $i
  208.     incr i
  209.     }
  210.     mailcap_load
  211.     MimeSunInit
  212. }
  213. proc Mime_Enabled {} {
  214.     global mime
  215.     return $mime(enabled)
  216. }
  217. proc Mime_Cleanup {{tkw default}} {
  218.     global mime mimeHdr mimeContentId
  219.  
  220.     eval File_Delete $mime(junkfiles)
  221.     set mime(junkfiles) {}
  222.  
  223.     catch {unset mimeHdr}
  224.     catch {unset mimeContentId}
  225.     if {[string compare $tkw default] != 0} {
  226.     if 0 {
  227.     foreach tag [$tkw tag names] {
  228.         if ![string match hdrlook=* $tag] {
  229.         catch {$tkw tag delete $tag}
  230.         }
  231.     }
  232.     }
  233.     foreach mark [$tkw mark names] {
  234.         catch {$tkw mark unset $mark}
  235.     }
  236.     foreach image [image names] {
  237.         if [string match ==image=* $image] {
  238.         catch {image delete $image}
  239.         }
  240.     }
  241.     }
  242. }
  243. proc MimeColor { tkw color } {
  244.     if {[string compare $color default] == 0} {
  245.     set color [lindex [$tkw configure -background] 4]
  246.     }
  247.     set rgb [winfo rgb $tkw $color]
  248.     return [format #%04x%04x%04x \
  249.     [lindex $rgb 0] [lindex $rgb 1] [lindex $rgb 2]]
  250. }
  251. # mimeHdr contains state about nested body parts:
  252. # mimeHdr($part,type)    Content-Type
  253. # mimeHdr($part,typeDescr)    Textual description of the type
  254. # mimeHdr($part,encoding)    Content-Transfer-Encoding
  255. # mimeHdr($part,file)    Tmp file containing body
  256. # mimeHdr($part,origFile)    if the body had to be decoded,
  257. #                undecoded version of file
  258. # mimeHdr($part,params)    Parameter names (e.g., boundary)
  259. # mimeHdr($part,param,$key)    Parameter value
  260. # mimeHdr($part,hdrs)    List of subpart mail headers
  261. # mimeHdr($part,hdr,$key)    Subpart mail header value
  262. # mimeHdr($part,display)    Flag determining if body is displayed
  263. # mimeHdr($part,color)    Color to use as background
  264. # mimeHdr($part,justDoIt)    Flag to execute body automatically
  265. # mimeHdr($part,menu)    Menu for this section
  266. # mimeHdr($part,HeaderSize)    The # of lines taken by the header
  267. # mimeHdr($part,decode)    Boolean to decode message 
  268. #
  269. # multipart and message only:
  270. # mimeHdr($part,numParts)    Number of subparts
  271. #
  272. # multipart/alternative only:
  273. # mimeHdr($part,chosenPart)    Part to display
  274. # mimeHdr($part,priorChosenPart)    Previous part displayed.
  275. #
  276. # message/rfc822 only:
  277. # mimeHdr($part,fullHeaders)    Boolean to display full headers
  278. #
  279. # multipart/report part 2 only:
  280. # mimeHdr($part,explainReport)  Display explanation of machine-readable part
  281. #                               of report.
  282. # mimeHdr($part,originalMessageDate)    Date of reported message, if known.
  283. # mimeHdr($part,originalMessageEnclosed)   Indicates whether the reported
  284. #                               message is enclosed as part 3 of multipart.
  285. #
  286. # images only:
  287. # mimeHdr($part,photo)        The image itself
  288.  
  289. proc MimeHeader {part contentType encoding} {
  290.     global mimeHdr
  291.  
  292.     set params [split $contentType \;]
  293.     # add stuff from Content-Disposition:
  294.     if {[info exists mimeHdr($part,hdr,content-disposition)]} {
  295.       set disp [split $mimeHdr($part,hdr,content-disposition) \;]
  296.       lappend params "disposition=[lindex $disp 0]"
  297.       eval lappend params [lrange $disp 1 end]
  298.     }
  299.     set type [string tolower [string trim [lindex $params 0]]]
  300.     if {[string compare $type "text"] == 0} {
  301.     set type text/plain
  302.     }
  303.     set mimeHdr($part,hdr,content-type) $contentType
  304.     set mimeHdr($part,type) $type
  305.     set mimeHdr($part,encoding) $encoding
  306.     set mimeHdr($part,params) {}
  307.     foreach sub [lrange $params 1 end] {
  308.     if [regexp {([^=]+)=(.+)} $sub match key val] {
  309.         set key [string trim [string tolower $key]]
  310.         set val [string trim $val]
  311.         # Allow single as well as double quotes
  312.         if [regexp {^[\"']} $val quote] {
  313.         if [regexp ^${quote}(\[^$quote\]+)$quote $val x val2] {
  314.             # Trim quotes and any extra crap after close quote
  315.             set val $val2
  316.         }
  317.         }
  318.         lappend mimeHdr($part,params) $key
  319.         set mimeHdr($part,param,$key) $val
  320.     }
  321.     }
  322.     if [info exists mimeHdr($part,hdr,x-sun-charset)] {
  323.     lappend mimeHdr($part,params) charset
  324.     set mimeHdr($part,param,charset) \
  325.         [string tolower $mimeHdr($part,hdr,x-sun-charset)]
  326.     }
  327.     # infer the name from the filename:
  328.     if {[info exists mimeHdr($part,param,filename)] &&
  329.       ![info exists mimeHdr($part,param,name)]} {
  330.       set mimeHdr($part,param,name) $mimeHdr($part,param,filename)
  331.     }
  332.     return $type
  333. }
  334. proc MimeShowPart {tkw part overTag only} {
  335.     global mimeHdr
  336.  
  337.     set partTag [MimeLabel $part part]
  338.     if ![info exists mimeHdr($part,decode)] {
  339.     # decode sub-parts by default, but not main body
  340.     set mimeHdr($part,decode) [string compare $part 0=1]
  341.     }
  342.     MimeWithTagging $tkw $partTag $overTag \
  343.             {-background $mimeHdr($part,color) \
  344.              -foreground [$tkw cget -foreground]} {
  345.     MimeSetPartVars desc displayedPart $tkw $part $partTag
  346.     MimeSetStdMenuItems $tkw $part
  347.     MimeShowPartHeader $tkw $part $partTag $only $displayedPart $desc
  348.     MimeShowPartBody $tkw $part
  349.     }
  350.     Exmh_Status $desc
  351. }
  352. proc Mime_TypeDescr {part} {
  353.     global mimeHdr
  354.  
  355.     if [info exists mimeHdr($part,typeDescr)] {
  356.     return $mimeHdr($part,typeDescr)
  357.     }
  358.     if [catch {set typeDescr [MimeGetRule $part "description" atrib]}] {
  359.     set typeDescr "a $mimeHdr($part,type)"
  360.     }
  361.     regsub -- "^A" $typeDescr "a" mimeHdr($part,typeDescr)
  362.     return $mimeHdr($part,typeDescr)
  363. }
  364. proc MimeSetCharset {tkw part} {
  365.     global mime mimeFont
  366.     set charset [Mime_GetCharset $tkw $part]
  367.     if ![info exists mimeFont(charset,$charset)] {
  368.     set mime(fontSize) [string trim $mime(fontSize)]
  369.     if [catch {Mime_GetFont $tkw medium r plain $mime(fontSize) $charset} \
  370.         font] {
  371.         MimeInsertNote $tkw [MimeLabel $part charset] "Error: $font"
  372.         $tkw insert insert \n
  373.         set mimeFont(charset,$charset) $mimeFont(default)
  374.     } else {
  375.         set mimeFont(charset,$charset) $font
  376.     }
  377.     }
  378.     set partTag [MimeLabel $part charset]
  379.     if [catch {$tkw tag configure $partTag -font $mimeFont(charset,$charset)} err] {
  380.     MimeInsertNote $tkw [MimeLabel $part charset] "Error: $err"
  381.     $tkw insert insert \n
  382.     Exmh_Status "No good font for $charset character set"
  383.     set mimeFont(charset,$charset) $mimeFont(default)
  384.     }
  385.     return $partTag
  386. }
  387. proc MimeSetStdMenuItems {tkw part} {
  388.     global mimeHdr env
  389.     set type $mimeHdr($part,type)
  390.  
  391.     if {[catch {set descr $mimeHdr($part,hdr,content-description)}] ||
  392.         ($descr == {})} {
  393.     set descr [Mime_TypeDescr $part]
  394.     }
  395.     if [info exists mimeHdr($part,file)] {
  396.     MimeMenuAdd $part checkbutton \
  397.         -label "Decode part as MIME" \
  398.         -command [list busy MimeRedisplayPart $tkw $part] \
  399.         -variable mimeHdr($part,decode)
  400.     MimeMenuAdd $part command \
  401.         -label "Save $descr..." \
  402.         -command [list Mime_SavePiece $part $type]
  403.     if [info exists mimeHdr($part,hdr,content-type)] {
  404.         set type $mimeHdr($part,hdr,content-type)
  405.     } else {
  406.         set type $mimeHdr($part,type)
  407.     }
  408.     set subparts {}
  409.     if [regexp {^multipart} $mimeHdr($part,type)] {
  410.         MimeChopPart $tkw $part
  411.         set numParts $mimeHdr($part,numParts)
  412.         for {set subpart 1} {$subpart <= $numParts} {incr subpart} {
  413.         lappend subparts \
  414.             [list $mimeHdr($part=$subpart,hdr,content-type) \
  415.                   $mimeHdr($part=$subpart,file)]
  416.         }    
  417.     }
  418.     if [MimeCheckRule $part ""] {
  419.         MimeMenuAdd $part command \
  420.         -label "View using mailcap rule..." \
  421.         -command [list MimeMailcapView $part $subparts]
  422.     }
  423.     if [MimeCheckRule $part "print"] {
  424.         MimeMenuAdd $part command \
  425.         -label "Print using mailcap rule..." \
  426.         -command [list MimeMailcapPrint $part $subparts]
  427.     } else {
  428.         MimeMenuAdd $part command \
  429.         -label "Print $descr as text..." \
  430.         -command [list Mime_PrintPiece $part $type]
  431.     }
  432.     if ![info exists env(NOMETAMAIL)] {
  433.         MimeMenuAdd $part command \
  434.         -label "Pass [Mime_TypeDescr $part] to metamail..." \
  435.         -command [list MimeMetaMail \
  436.                    $type \
  437.                    $mimeHdr($part,encoding) \
  438.                    [MimeGetOrigFile $part]]
  439.     }
  440.     }
  441. }
  442. proc MimeShowPartBody {tkw part} {
  443.     global mime mimeHdr
  444.  
  445.     MimeSetCharset $tkw $part
  446.  
  447.     if !$mimeHdr($part,decode) {
  448.     Mime_WithTextFile fileIO $tkw $part {
  449.         $tkw insert insert [read $fileIO]
  450.     }
  451.     } elseif [info exists mimeHdr($part,file)] {
  452.     set fileName $mimeHdr($part,file)
  453.     set type $mimeHdr($part,type)
  454.  
  455.     foreach t [list $type [file dirname $type] default] {
  456.         if [info exists mime(showproc,$t)] {
  457.         if [catch {$mime(showproc,$t) $tkw $part} err] {
  458.             Exmh_Status "$err in $mime(showproc,$t)"
  459.             Mime_ShowDefault $tkw $part  
  460.             #$mime(showproc,$t) $tkw $part
  461.         }
  462.         return
  463.         }
  464.     }
  465.     } else {
  466.     $tkw insert insert "You have received a reference to a $mimeHdr($part,type)\n"
  467.     MimeInsertInfo $tkw $part
  468.     }
  469. }
  470. proc MimeWithDisplayHiding {tkw part body} {
  471.     global mimeHdr
  472.  
  473.     MimeMenuAdd $part checkbutton \
  474.         -label "Display inline" \
  475.         -command [list busy MimeRedisplayPart $tkw $part] \
  476.         -variable mimeHdr($part,display)
  477.     if {$mimeHdr($part,display)} {
  478.     uplevel $body
  479.     } else {
  480.         $tkw insert insert ". . .\t\t\t\t\t\t"
  481.         MimeInsertNote $tkw [MimeLabel $part part] \
  482.                 "Invoke menu with right button."
  483.     }
  484. }
  485. proc MimeSetPartVars {descVar displayedPartVar tkw part partTag} {
  486.     global mimeHdr msg
  487.     upvar $descVar desc
  488.  
  489.     set desc {}
  490.     MimeMapSunHeaders $tkw $part
  491.  
  492.     if ![info exists mimeHdr($part,type)] {
  493.     set mimeHdr($part,type) text/plain
  494.     }
  495.  
  496.     if {([string compare $mimeHdr($part,type) message/sample] == 0) ||
  497.     ([string compare $mimeHdr($part,type) message/news] == 0)} {
  498.       set mimeHdr($part,type) message/rfc822
  499.     }
  500.     if {([string compare $mimeHdr($part,type) message/rfc822] == 0) && \
  501.     ![info exists mimeHdr($part,numParts)]} {
  502.     #
  503.     # This is the first pass over the message from ShowInText
  504.     #
  505.     set fileName $mimeHdr($part,file)
  506.  
  507.     if {![catch {file size $fileName} size] &&
  508.         $size > $msg(maxsize)} {
  509.         # Display stop button
  510.         MimeSizeDialog $tkw $size
  511.     }
  512.     if [catch {open $fileName r} fileIO] {
  513.         Exmh_Status "Cannot open body $fileName: $fileIO"
  514.         set mimeHdr($part,numParts) 0
  515.         return
  516.     }
  517.     set mimeHdr($part,numParts) [MimeParseSingle $tkw $part $fileIO]
  518.     MimeClose $fileIO
  519.     MimeSizeDialogCleanup $tkw
  520.     if {$mimeHdr($part,numParts) == 0} {
  521.         set desc $mimeHdr(${part}=1,hdr,subject)
  522.         return;    # fastpath
  523.     }
  524.     }
  525.     MimeSetDisplayFlag $part
  526.     global mimeContentId
  527.     upvar $displayedPartVar displayedPart
  528.  
  529.  
  530.     # Cache content-id data.  Basically, if this part has a content-id
  531.     # header that we've seen before, use the file that was associated
  532.     # with the first reference to this content-id instead of the one
  533.     # that we would otherwise use.  If this part is external, we cache
  534.     # the first reference which is actually retrieved.  Except for not
  535.     # redisplaying any other references to the same external part, I think
  536.     # this'll do the right thing. 
  537.     if [info exists mimeHdr($part,hdr,content-id)] {
  538.     if [info exists mimeContentId($mimeHdr($part,hdr,content-id))] {
  539.         set mimeHdr($part,file) \
  540.         $mimeContentId($mimeHdr($part,hdr,content-id)) 
  541.     } elseif [info exists mimeHdr($part,file)] {
  542.         set mimeContentId($mimeHdr($part,hdr,content-id)) \
  543.         $mimeHdr($part,file)
  544.     }
  545.     }
  546.  
  547.     if {[string compare $mimeHdr($part,type) "application/octet-stream"] \
  548.      == 0} {
  549.     if [string length [set type [Mime_Magic \
  550.      [Mime_GetUnencodedFile $part]]]] {
  551.         set mimeHdr($part,hdr,content-description) $type
  552.         regsub octet-stream $mimeHdr($part,hdr,content-type) \
  553.          $type mimeHdr($part,hdr,content-type)
  554.         set mimeHdr($part,type) $type
  555.     }
  556.     }
  557.  
  558.     foreach key [list $part,hdr,content-description \
  559.               $part,param,name \
  560.               $part=1,hdr,subject] {
  561.         if ![catch {set desc $mimeHdr($key)}] {
  562.         break
  563.     }
  564.     }
  565.  
  566.     # Slight tweak because of TCL 7.0 regsub bug
  567.     set displayedPart [string range "$part=" 4 end]
  568.     regsub -all -- = $displayedPart . displayedPart
  569.  
  570.     if {[string length $desc] != 0} {
  571.     MimeMakeMenu $tkw $partTag $part "$displayedPart $desc"
  572.     } else {
  573.     MimeMakeMenu $tkw $partTag $part $displayedPart
  574.     }     
  575. }
  576. proc MimeSizeDialog {t size} {
  577.     global mime
  578.     catch {destroy $t.size}
  579.     set g [frame $t.size -bd 4 -relief raised]
  580.     set f [frame $g.pad -bd 20]
  581.     set msg [Widget_Message $f msg -text \
  582.     "Very Large Message: $size bytes" -width 200]
  583.     Widget_AddBut $f stop STOP {set mime(stop) 1} {top padx 2 pady 2 filly}
  584.     bind $f.stop <Any-Key> {set mime(stop) 1; Exmh_Status Stop warn}
  585.     pack $f
  586.     Widget_PlaceDialog $t $g
  587.     Visibility_Wait $f.stop
  588.     catch {focus $f.stop}
  589.     catch {grab $f.stop}
  590.     set mime(grab) 1
  591.     return $g
  592. }
  593. proc MimeSizeDialogCleanup {t} {
  594.     global mime
  595.     catch {destroy $t.size}
  596.     set mime(grab) 0
  597.     set mime(stop) 0
  598.     Exmh_Focus
  599. }
  600. proc MimeClose { fileIO } {
  601.     if [catch {close $fileIO} err] {
  602.     Exmh_Status $err error
  603.     }
  604. }
  605. proc MimeSetDisplayFlag {part} {
  606.     global mime mimeHdr msg
  607.  
  608.     # Flag to determine if we display the part or not.    We display it
  609.     # if it's a multipart (other than multipart/parallel).  We display 
  610.     # it if it's an image (unless we aren't supposed to do that.  Otherwise,
  611.     # we display it unless we've been told not to or it's too darn big.
  612.     if {[info exists mimeHdr($part,file)]} {
  613.     if [regexp {^multipart} $mimeHdr($part,type)] {
  614.         set mimeHdr($part,display) \
  615.         [expr ![regexp {parallel$} $mimeHdr($part,type)]]
  616.         return
  617.     } elseif [regexp {^image} $mimeHdr($part,type)] {
  618.         set mimeHdr($part,display) $mime(showImage)
  619.         return
  620.     }
  621.     if [regexp {^text.*vcard} $mimeHdr($part,type)] {
  622.         set mimeHdr($part,display) 0
  623.         Exmh_Debug "vcard: not displaying"
  624.         return
  625.     }
  626.     if {[info exists mimeHdr($part,hdr,content-disposition)]} {
  627.         set disp [split $mimeHdr($part,hdr,content-disposition) \;]
  628.         if [regexp {ancillary} [lindex $disp 0]] {
  629.         set mimeHdr($part,display) 0
  630.         return
  631.         }
  632.     }
  633.     if ![info exists mimeHdr($part,display)] {
  634.         set mimeHdr($part,display) \
  635.         [expr {[file exists $mimeHdr($part,file)] && \
  636.             ([file size $mimeHdr($part,file)] < $msg(maxsize))}]
  637.     }
  638.     }
  639. }
  640. proc MimeShowPartHeader {tkw part partTag only displayedPart desc} {
  641.     global mimeHdr mime mimeFont
  642.  
  643.     set mimeHdr($part,HeaderSize) 0
  644.  
  645.     if {(!$only) || ([string length $desc] != 0)} {
  646.     MimeWithTagging $tkw titleTag $partTag {-font $mimeFont(title)} {
  647.         set triangle $tkw.[MimeLabel $part triangle]
  648.         if [winfo exists $triangle] {
  649.         $triangle create rectangle 0 0 10 10 \
  650.             -fill $mimeHdr($part,color) \
  651.             -outline $mimeHdr($part,color)
  652.         } else {
  653.         canvas $triangle -background $mimeHdr($part,color) \
  654.             -height 10 -width 10 -cursor arrow
  655.         bind $triangle <ButtonPress-1> \
  656.             [list busy MimeTogglePartDisplay $tkw $part] 
  657.         set menu $mimeHdr($part,menu)
  658.         bind $triangle <ButtonPress-3> "tk_popup $menu %X %Y"
  659.         }
  660.         if $mimeHdr($part,display) {
  661.         $triangle create line 5 0 5 10 -arrow last 
  662.         } else {
  663.         $triangle create line 0 5 10 5 -arrow last 
  664.         }
  665.         $tkw window create insert -window $triangle -padx 0 -pady 0
  666.         $tkw insert insert "$displayedPart\t"
  667.         set mimeHdr($part,HeaderSize) 1
  668.         if {[string length $desc] != 0} {
  669.         MimeWithTagging $tkw descTag titleTag {-underline 1} {
  670.             Mime_PrintEncodedHeader $tkw descTag $desc \
  671.                         bold r title $mime(titleSize)
  672.         }
  673.         set mimeHdr($part,HeaderSize) 1
  674.         }
  675.     }
  676.     }
  677.  
  678.     if {$mime(showType)} {
  679.     $tkw insert insert \t
  680.     MimeInsertNote $tkw $partTag $mimeHdr($part,type) 0
  681.     set mimeHdr($part,HeaderSize) 1
  682.     }
  683.     if $mimeHdr($part,HeaderSize) {
  684.     $tkw insert insert \n
  685.     }
  686. }
  687. proc MimeTogglePartDisplay {tkw part} {
  688.     global mimeHdr
  689.  
  690.     set mimeHdr($part,display) [expr {!$mimeHdr($part,display)}]
  691.     MimeRedisplayPart $tkw $part
  692. }
  693. proc MimeRedisplayPart {tkw part} {
  694.     global mimeHdr
  695.  
  696.  
  697.     if ![info exists mimeHdr($part,HeaderSize)] {
  698.     # Text part with bogus MIME menu
  699.     return
  700.     }
  701.     $tkw configure -state normal
  702.     set partTag [MimeLabel $part part]
  703.     set start [$tkw index "$partTag.first + $mimeHdr($part,HeaderSize) line"]
  704.     set end [$tkw index $partTag.last]
  705.  
  706.     MimeClearHigherTags $tkw $partTag $start $end
  707.     $tkw mark set insert $end
  708.  
  709.     MimeWithTagging $tkw $partTag {} {} {
  710.  
  711.     set triangle $tkw.[MimeLabel $part triangle]
  712.     if { ![winfo exists $triangle]} {
  713.                 canvas $triangle -background $mimeHdr($part,color) \
  714.                         -height 10 -width 10 -cursor arrow
  715.                 bind $triangle <ButtonPress-1> \
  716.                         [list busy MimeTogglePartDisplay $tkw $part]
  717.                 set menu $mimeHdr($part,menu)
  718.                 bind $triangle <ButtonPress-3> "tk_popup $menu %X %Y"
  719.         }                                 
  720.  
  721.     $triangle create rectangle 0 0 10 10 \
  722.         -fill $mimeHdr($part,color) \
  723.         -outline $mimeHdr($part,color)
  724.     if $mimeHdr($part,display) {
  725.         $triangle create line 5 0 5 10 -arrow last 
  726.     } else {
  727.         $triangle create line 0 5 10 5 -arrow last 
  728.     }
  729.     MimeShowPartBody $tkw $part
  730.  
  731.     if [$tkw compare insert != "insert linestart"] {
  732.         $tkw insert insert "\n"
  733.     }
  734.     }
  735.  
  736.     MimeCleanTag $tkw 1
  737.     $tkw delete $start $end
  738.     $tkw mark set insert end
  739.     Exmh_Status "Redisplayed $part"
  740.  
  741.     $tkw configure -state disabled
  742. }
  743. proc MimeRedisplaySubpart {tkw part} {
  744.     global mimeHdr
  745.  
  746.     set partTag [MimeLabel \
  747.             $part=$mimeHdr($part,priorChosenPart) \
  748.             part]
  749.     if [catch {
  750.     set start [$tkw index $partTag.first]
  751.     set end [$tkw index $partTag.last]
  752.     }] {
  753.     return
  754.     }
  755.  
  756.     $tkw configure -state normal
  757.     MimeClearHigherTags $tkw $partTag $start $end
  758.     $tkw mark set insert $end
  759.  
  760.     MimeWithTagging $tkw partTag {} {} {
  761.     MimeShowPart $tkw $part=$mimeHdr($part,chosenPart) \
  762.              [MimeLabel $part part] 1
  763.     set mimeHdr($part,priorChosenPart) \
  764.         $mimeHdr($part,chosenPart)
  765.     }
  766.  
  767.     MimeCleanTag $tkw 1     
  768.     $tkw delete $start $end
  769.     $tkw mark set insert end
  770.     Exmh_Status "Redisplayed $part=$mimeHdr($part,chosenPart)"
  771.     
  772.     $tkw configure -state disabled
  773. }
  774. proc Mime_ShowImage {tkw part} {
  775.     global mimeHdr mime
  776.     MimeWithDisplayHiding $tkw $part {
  777.     if [catch {
  778.         set subtype [file tail $mimeHdr($part,type)]
  779.         if [info exists mime(imageFilter,$subtype)] {
  780.         set newFile [Mime_TempFile $part]
  781.         Exmh_Status "Running $subtype filter: $mime(imageFilter,$subtype)"
  782.         if [catch {eval exec $mime(imageFilter,$subtype) < $mimeHdr($part,file) > $newFile} err] {
  783.             Exmh_Debug "$err while running $mime(imageFilter,$subtype)"
  784.         }
  785.         set mimeHdr($part,origFile) mimeHdr($part,file)
  786.         set mimeHdr($part,file) $newFile
  787.         set mimeHdr($part,type) "image/x-ppm"
  788.         }
  789.         if ![info exists mimeHdr($part,photo)] {
  790.         Exmh_Status "Creating tk photo"
  791.         set mimeHdr($part,photo) \
  792.             [image create photo [MimeLabel $part image] \
  793.             -file $mimeHdr($part,file)]
  794.         Exmh_Status "Created tk photo"
  795.         }
  796.         set photo $tkw.[MimeLabel $part photo]
  797.         canvas $photo -height [image height $mimeHdr($part,photo)] \
  798.                       -width [image width $mimeHdr($part,photo)]
  799.         $photo create image 0 0 -image $mimeHdr($part,photo) \
  800.                                 -anchor "nw" 
  801.         $tkw window create insert -window $photo
  802.         set menu $mimeHdr($part,menu)
  803.         bind $photo <ButtonPress-3> "tk_popup $menu %X %Y"
  804.         $tkw insert insert "\n"
  805.     } err] {
  806.         Exmh_Debug "$err while displaying photo"
  807.         if ![catch {MimeGetRule $part "" atrib} viewer] {
  808.         MimeInsertInfo $tkw $part
  809.         $tkw insert insert "Opening viewer with:\n"
  810.         $tkw insert insert "$viewer\n"
  811.         if [info exists atrib(needsterminal)] {
  812.             exec xterm -e sh -c $viewer &
  813.         } else {
  814.             exec sh -c $viewer > /dev/null &
  815.         }
  816.         } else {
  817.         Mime_ShowDefault $tkw $part
  818.         }
  819.     }
  820.     }
  821. }
  822. proc Mime_ShowDefault {tkw part} {
  823.     global mimeHdr env
  824.  
  825.     Mime_GetUnencodedFile $part
  826.     if [regexp {^multipart} $mimeHdr($part,type)] {
  827.     if ![info exists mimeHdr($part,showParts)] {
  828.         set mimeHdr($part,showParts) 0
  829.         MimeMenuAdd $part checkbutton \
  830.         -label "Display Parts" \
  831.         -command [list busy MimeRedisplayPart $tkw $part] \
  832.         -variable mimeHdr($part,showParts)
  833.     }
  834.     }
  835.     if {[regexp {^multipart} $mimeHdr($part,type)] && \
  836.          $mimeHdr($part,showParts)} {
  837.     $tkw insert insert "This is [Mime_TypeDescr $part]\t\t"
  838.     MimeInsertNote $tkw [MimeLabel $part part] \
  839.                "Invoke menu with right button."
  840.     Mime_ShowMultipart $tkw $part
  841.     } elseif {![catch {set viewer [MimeGetRule $part "" atrib]}] && 
  842.     [info exists atrib(copiousoutput)]} {
  843.     if ![info exists mimeHdr($part,copiousOut)] {
  844.         set newFile [Mime_TempFile $part]
  845.         if [catch {exec sh -c $viewer > $newFile} err] {
  846.         if ![catch {open $newFile w} x] {
  847.             puts $x $err
  848.             catch {close $x}
  849.         }
  850.         }
  851.         set mimeHdr($part,copiousOut) $newFile
  852.     }
  853.     MimeWithDisplayHiding $tkw $part {
  854.         if [catch {open $mimeHdr($part,copiousOut) r} fileIO] {
  855.         Exmh_Status "Cannot open body $mimeHdr($part,copiousOut): $fileIO"
  856.         return 1
  857.         }
  858.         set start [$tkw index insert]
  859.         $tkw insert insert [read $fileIO]
  860.         MimeClose $fileIO
  861.         set end [$tkw index insert]
  862.         Msg_TextHighlight $tkw $start $end
  863.     }
  864.     } else {
  865.     $tkw insert insert "This is [Mime_TypeDescr $part]\n"
  866.     if [info exists viewer] {
  867.         if ![info exists atrib(copiousoutput)] {
  868.         $tkw insert insert "It can be displayed with \"$viewer\".\t"
  869.         MimeInsertNote $tkw [MimeLabel $part part] \
  870.             "Invoke menu with right button."
  871.         }
  872.     } elseif ![info exists env(NOMETAMAIL)] {
  873.         $tkw insert insert "It might be displayable with metamail.\t"
  874.         MimeInsertNote $tkw [MimeLabel $part part] \
  875.         "Invoke menu with right button."
  876.     }
  877.     if [regexp {^multipart} $mimeHdr($part,type)] {
  878.         $tkw insert insert "Its subparts may be displayed individually.\t"
  879.         MimeInsertNote $tkw [MimeLabel $part part] \
  880.         "Invoke menu with right button."
  881.         }
  882.     if [regexp {^text} $mimeHdr($part,type)] {
  883.         Mime_ShowText $tkw $part
  884.     } else {
  885.         MimeInsertInfo $tkw $part
  886.     }
  887.     if [info exists mimeHdr($part,justDoIt)] {
  888.         if [info exists viewer] {
  889.         if ![info exists atrib(copiousoutput)] {
  890.             if [info exists atrib(needsterminal)] {
  891.             exec xterm -e sh -c $viewer &
  892.             } else {
  893.             exec sh -c $viewer &
  894.             }
  895.         }
  896.         } elseif ![info exists env(NOMETAMAIL)] {
  897.         MimeMetaMail $mimeHdr($part,hdr,content-type) \
  898.                  $mimeHdr($part,encoding) \
  899.                  [MimeGetOrigFile $part]
  900.         } else {
  901.         Exmh_Status "Couldn't display part $part"
  902.         }
  903.     }
  904.     }
  905.     return 0
  906. }
  907. proc MimeInsertInfo {tkw part} {
  908.     global mimeHdr
  909.  
  910.     foreach key $mimeHdr($part,params) {
  911.     $tkw insert insert "\t$key = $mimeHdr($part,param,$key)\n"
  912.     }
  913.  
  914.     if ![info exists mimeHdr($part,param,URI)] {
  915.         MimeAddURIInfo $tkw $part
  916.     }
  917. }
  918. proc MimeAddURIInfo { tkw part } {
  919.     global mimeHdr
  920.  
  921.     if [info exists mimeHdr($part,param,access-type)] {
  922.         if [string compare ANON-FTP $mimeHdr($part,param,access-type)] {
  923.            return
  924.         }
  925.     }
  926.  
  927.     set uri ftp:/
  928.     foreach uripart {site directory name} {
  929.         if ![info exists mimeHdr($part,param,$uripart)] return
  930.         append uri /$mimeHdr($part,param,$uripart)
  931.     }
  932.     $tkw insert insert "\tURI = $uri\n"
  933. }
  934. proc MimeMetaMail {contentType encoding fileName} {
  935.     global mimeHdr
  936.  
  937.     if [catch {
  938.     Exmh_Status "metamail $fileName -c $contentType ..."
  939.     set mcmd [list exec metamail -b\
  940.             -c $contentType \
  941.             -E $encoding \
  942.             -f [MsgParseFrom $mimeHdr(0=1,hdr,from)] \
  943.             -m exmh ]
  944.     if [regexp -nocase {^audio|^image|^video} $contentType] {
  945.         lappend mcmd -B
  946.     } else {
  947.         lappend mcmd -p
  948.     }
  949.     lappend mcmd $fileName < /dev/null > /dev/null &
  950.     # recall that eval concats its arguments, thus exploding things for us
  951.     Exmh_Debug $mcmd
  952.     eval $mcmd
  953.     } err] {
  954.      Exmh_Status "$err"
  955.     }
  956. }
  957.  
  958. proc Mime_ShowText {tkw part} {
  959.     global mimeHdr mime miscRE pgp
  960.  
  961.     MimeWithDisplayHiding $tkw $part {
  962.     set subtype [file tail $mimeHdr($part,type)]
  963.     Mime_WithTextFile fileIO $tkw $part {
  964.         gets $fileIO firstLine
  965.         if {$pgp(enabled) && [regexp $miscRE(beginpgp) $firstLine]} {
  966.         # convert from text/plain to application/pgp
  967.         set mimeHdr($part,type) "application/pgp"
  968.         catch { unset mimeHdr($part,typeDescr) }
  969.                 if {[info exists mimeHdr($part,param,format)]} {
  970.                     unset mimeHdr($part,param,format)
  971.                     set i [lsearch $mimeHdr($part,params) format]
  972.                     set mimeHdr($part,params) \
  973.                         [lreplace $mimeHdr($part,params) $i $i]
  974.                 }
  975.         Pgp_ShowMessage $tkw $part
  976.         } else {
  977.         set textStart [$tkw index insert]
  978.         $tkw insert insert "$firstLine\n"
  979.         $tkw insert insert [read $fileIO]
  980.         set textEnd [$tkw index insert]
  981.         Msg_TextHighlight $tkw $textStart $textEnd
  982.         }
  983.     }
  984.     }
  985.     return 1
  986. }
  987. proc Mime_ShowMsWord { tkw part } {
  988.     global mimeHdr mime miscRE
  989.     
  990.     MimeWithDisplayHiding $tkw $part {
  991.     set subtype [file tail $mimeHdr($part,type)]
  992.     Mime_WithTextFile fileIO $tkw $part {
  993.         gets $fileIO firstLine
  994.         if [regexp $miscRE(beginpgp) $firstLine] {
  995.         set mimeHdr($part,type) "application/pgp"
  996.         catch { unset mimeHdr($part,typeDescr) }
  997.         Pgp_ShowMessage $tkw $part
  998.         } else {
  999.         set fileName [Mime_GetUnencodedFile $part]
  1000.         if {[catch {open "| antiword $fileName" r} G] && \
  1001.                        [catch {open "| lhalw -F $fileName" r} G]} {
  1002.             return 0
  1003.         }
  1004.         $tkw insert insert [read $G]
  1005.         close $G
  1006.         }
  1007.     }
  1008.     }
  1009.     return 1
  1010. }
  1011.  
  1012. proc Mime_ShowRichText {tkw part} {
  1013.     global mimeHdr mime
  1014.  
  1015.     MimeWithDisplayHiding $tkw $part {
  1016.     set subtype [file tail $mimeHdr($part,type)]
  1017.     Mime_WithTextFile fileIO $tkw $part {
  1018.         Rich_Display $tkw $fileIO $part $subtype
  1019.     }
  1020.     }
  1021.     return 1
  1022. }
  1023. proc Mime_WithTextFile {fileIOVar tkw part body} {
  1024.     upvar $fileIOVar fileIO
  1025.  
  1026.     set fileName [Mime_GetUnencodedFile $part]
  1027.     if {[string length $fileName] == 0} {
  1028.     return
  1029.     }
  1030.     if [catch {open $fileName r} fileIO] {
  1031.     Exmh_Status "Cannot open body $fileName: $fileIO"
  1032.     return 1
  1033.     }
  1034.  
  1035.     # Set the encoding for the file based on its character set
  1036.  
  1037.     Mime_SetFileEncoding $fileIO $part
  1038.  
  1039.     # Errors or "return" statements hit this catch
  1040.  
  1041.     set code [catch {uplevel $body} err]
  1042.  
  1043.     MimeClose $fileIO
  1044.  
  1045.     # Reflect errors or early returns like a true control structure
  1046.  
  1047.     return -code $code $err
  1048. }
  1049.  
  1050. proc Mime_SetFileEncoding {fileIO part} {
  1051.     global tcl_version
  1052.     if {$tcl_version >= 8.1} {
  1053.     set charset [Mime_GetCharset {} $part]
  1054.     regsub {^us-} $charset {} charset
  1055.     regsub {^(mac|iso)-} $charset {\1} charset
  1056.     if {[catch {fconfigure $fileIO -encoding $charset} err]} {
  1057.         Exmh_Debug "Mime_SetFileEncoding: $err"
  1058.     }
  1059.     }
  1060. }
  1061.  
  1062. proc Mime_GetUnencodedFile {part} {
  1063.     global mimeHdr mime
  1064.  
  1065.     if ![info exists mimeHdr($part,file)] {
  1066.     return {}
  1067.     }
  1068.     set fileName $mimeHdr($part,file)
  1069.     if ![info exists mimeHdr($part,origFile)] {
  1070.     set encoding $mimeHdr($part,encoding)
  1071.     if [regexp {^([78]bit|binary)$} $encoding] {
  1072.         set mimeHdr($part,origFile) $fileName
  1073.     } else {
  1074.         # Generate a new name with a template
  1075.         set newFile [Mime_TempFile $part]
  1076.         if {![MimeDecode $mimeHdr($part,file) \
  1077.                 $newFile $encoding \
  1078.                 [regexp {^text} $mimeHdr($part,type)]] &&
  1079.             !$mime(stop)} {
  1080.         set mimeHdr($part,origFile) $fileName
  1081.         Exmh_Status "Decode failed - raw text follows"
  1082.         set mimeHdr($part,type) text/plain
  1083.         set mimeHdr($part,encoding) 8bit
  1084.         } else {
  1085.         set mimeHdr($part,origFile) $fileName
  1086.         set fileName $newFile
  1087.         set mimeHdr($part,file) $newFile
  1088.         }
  1089.     }
  1090.     }
  1091.     return $fileName
  1092. }
  1093. proc Mime_GetCharset {tkw part} {
  1094.     global mimeHdr mime
  1095.  
  1096.     set charset us-ascii
  1097.     if [info exists mimeHdr($part,param,charset)] {
  1098.     set charset [string tolower $mimeHdr($part,param,charset)]
  1099.  
  1100.     # Limit the encodings to ones for which we have fonts.
  1101.  
  1102.     if ![info exists mime(registry,$charset)] {
  1103.         if {[string length $tkw]} {
  1104.  
  1105.         MimeInsertNote $tkw [MimeLabel $part charset] \
  1106.                    "Unknown charset: <$charset>"
  1107.         $tkw insert insert \n
  1108.         }
  1109.         set charset us-ascii
  1110.     }
  1111.     }
  1112.     return $charset
  1113. }
  1114. proc Mime_ShowRfc822 {tkw part} {
  1115.     global mimeHdr mime mhProfile exmh 
  1116.  
  1117.     set mimeHdr($part=1,color) $mimeHdr($part,color)
  1118.  
  1119.     Mime_GetUnencodedFile $part=1
  1120.  
  1121.     MimeWithDisplayHiding $tkw $part {
  1122.     if ![info exists mimeHdr($part=1,fullHeaders)] {
  1123.         set mimeHdr($part=1,fullHeaders) $mime(fullHeaders)
  1124.     }
  1125.     MimeShowHeaders $tkw $part=1 [MimeLabel $part part]
  1126.     MimeInsertSeparator $tkw $part 6
  1127.         if {$part == 0} {
  1128.         MDNCheck $tkw
  1129.         }
  1130.  
  1131.     MimeShowPart $tkw $part=1 [MimeLabel $part part] 1
  1132.     }
  1133.     if {[string compare $part "0"] != 0} {
  1134.     MimeMenuAdd $part checkbutton \
  1135.         -label "Show full message headers" \
  1136.         -command [list busy MimeRedisplayHeaders $tkw $part=1] \
  1137.         -variable mimeHdr($part=1,fullHeaders)
  1138.     MimeMenuAdd $part command \
  1139.         -label "Extract a message/rfc822 into current folder" \
  1140.         -command [list busy MimeExtractMessage $tkw $part]
  1141.     }
  1142.     return 1
  1143. }
  1144.  
  1145. proc MimeExtractMessage {tkw part} {
  1146.     global exmh mimeHdr
  1147.  
  1148.     Mh_RefileFile $exmh(folder) $mimeHdr($part,file)
  1149.     Scan_Folder $exmh(folder) 0
  1150.     Exmh_Status "Extraction of part $part...done" blue
  1151. }
  1152.  
  1153. proc Mime_ShowMDN {tkw part} {
  1154.     Mime_ShowReport $tkw $part report { Mime_ExplainMDN $tkw $part report }
  1155. }
  1156.  
  1157. proc Mime_ShowDSN {tkw part} {
  1158.     Mime_ShowReport $tkw $part report { Mime_ExplainDSN $tkw $part report }
  1159. }
  1160.  
  1161. proc Mime_ShowReport {tkw part reportVar body } {
  1162.     global mimeHdr mime
  1163.     upvar $reportVar report
  1164.  
  1165.     if ![info exists mimeHdr($part,explainReport)] {
  1166.     set mimeHdr($part,explainReport) $mime(explainReport)
  1167.     }
  1168.  
  1169.     if {[string compare $part "0"] != 0} {
  1170.     MimeMenuAdd $part checkbutton \
  1171.         -label "Show explanation" \
  1172.         -command [list busy MimeRedisplayPart $tkw $part] \
  1173.         -variable mimeHdr($part,explainReport)
  1174.     }
  1175.  
  1176.     if [Mime_ShowText $tkw $part] {
  1177.     if { $mimeHdr($part,explainReport) && $mimeHdr($part,display) } {
  1178.         MimeInsertSeparator $tkw $part 6
  1179.  
  1180.         ParseReport $part report
  1181.  
  1182.         if [info exists report(original-recipient)] {
  1183.         set recipient $report(original-recipient)
  1184.         } elseif [info exists report(final-recipient)] {
  1185.         set recipient $report(final-recipient)
  1186.         } else {
  1187.         set recipient "(unknown)"
  1188.         }
  1189.  
  1190.         $tkw insert insert \
  1191.             "This is a report concerning the message you sent\
  1192.          \n  to:      $recipient"
  1193.  
  1194.         if [info exists mimeHdr($part,originalMessageDate)] {
  1195.         $tkw insert insert \
  1196.         "\n  on date: $mimeHdr($part,originalMessageDate)"
  1197.         }
  1198.  
  1199.         if [info exists mimeHdr($part,originalMessageEnclosed)] {
  1200.         if { $mimeHdr($part,originalMessageEnclosed) } {
  1201.             $tkw insert insert "\n(A copy of the\
  1202.                         message is included below.)"
  1203.         }
  1204.         }
  1205.  
  1206.         $tkw insert insert "\n\n"
  1207.  
  1208.         uplevel $body
  1209.     } else {
  1210.         return 1
  1211.     }
  1212.     } else {
  1213.     return 0
  1214.     }
  1215. }
  1216.  
  1217. proc MimeShowHeaders {tkw part overTag} {
  1218.     global mimeHdr
  1219.  
  1220.     set inlin [expr {[string compare $part "0=1"] == 0}]
  1221.     MimeWithTagging $tkw [MimeLabel $part headers] $overTag {} {
  1222.     if $mimeHdr($part,fullHeaders) {
  1223.         MimeShowFullHeaders $tkw $part $inlin
  1224.     } else {
  1225.         MimeShowMinHeaders $tkw $part $inlin
  1226.     }
  1227.     }
  1228. }
  1229. proc MimeShowFullHeaders {tkw part inlin} {
  1230.     global mimeHdr msg mime
  1231.  
  1232.     if {$inlin} {
  1233.     set mimeHdr($part,yview) 1.0
  1234.     }
  1235.     if [info exists mimeHdr($part,hdrs)] {
  1236.     foreach hdr $mimeHdr($part,hdrs) {
  1237.         set start [$tkw index insert]
  1238.         # Check for multiple headers
  1239.         # Replied:
  1240.         # :0:Replied:
  1241.         # :1:Replied:
  1242.         if ![regsub {^:[0-9]+:} $hdr {} truehdr] {
  1243.         set truehdr $hdr
  1244.         }
  1245.         $tkw insert insert [string toupper [string index $truehdr 0]]
  1246.         $tkw insert insert "[string range $truehdr 1 end]: "
  1247.         set tag [Mime_PrintEncodedHeader $tkw [MimeLabel $part headers] \
  1248.                     $mimeHdr($part,hdr,$hdr) \
  1249.                     medium r plain $mime(fontSize)]
  1250.         if [regexp -nocase date $truehdr] {
  1251.         MimeShowTime $tkw $mimeHdr($part,hdr,$hdr)
  1252.         }
  1253.         $tkw insert insert \n
  1254.         foreach key [list $truehdr default] {
  1255.         if [info exists msg(tag,$key)] {
  1256.             $tkw tag add hdrlook=$key $start "insert -1 char"
  1257.             if {[string length $tag] != 0} {
  1258.             $tkw tag lower hdrlook=$key $tag
  1259.             }
  1260.             break
  1261.         }
  1262.         }
  1263.     }
  1264.     }
  1265. }
  1266.  
  1267. # Show local time if message from another tz
  1268. # e.g.
  1269. #      Mon, 18 May 1998 11:58:39 GMT
  1270. # is shown as
  1271. #      Mon, 18 May 1998 11:58:39 GMT (13:58 MET DST)
  1272. #
  1273.  
  1274. proc MimeShowTime { tkw time } {
  1275.     global mime
  1276.  
  1277.     catch {
  1278.     set msgtime   [clock scan $time]
  1279.     set localtime [clock format $msgtime -format " %T"]
  1280.     if { [string first $localtime $time] == -1 } {
  1281.         Preferences_Resource mime(localTimeFormat) localTimeFormat \
  1282.         "%H:%M %Z"
  1283.         set format $mime(localTimeFormat)
  1284.         set day [clock format $msgtime -format %a]
  1285.         if { [string first $day $time] == -1 } {
  1286.         set format "%a $format"
  1287.         }
  1288.         set msgtime [clock format $msgtime -format $format]
  1289.         $tkw insert insert " ($msgtime)"
  1290.     }
  1291.     }
  1292. }
  1293.  
  1294. proc MimeSortHeaders { a b } {
  1295.     global mhProfile
  1296.  
  1297.    return [expr [lsearch -regexp $mhProfile(header-display) $a] - \
  1298.     [lsearch -regexp $mhProfile(header-display) $b]]
  1299.  
  1300. }
  1301. proc MimeShowMinHeaders {tkw part inlin} {
  1302.     global mimeHdr mhProfile msg mime
  1303.     
  1304.     if ![info exists mimeHdr($part,hdrs)] {
  1305.         return
  1306.     }
  1307.     set hideMark 1.0
  1308.  
  1309.     foreach hdr [lsort -command MimeSortHeaders $mimeHdr($part,hdrs)] {
  1310.         # Check for multiple headers
  1311.     # Replied:
  1312.     # :0:Replied:
  1313.     # :1:Replied:
  1314.     if ![regsub {^:[0-9]+:} $hdr {} truehdr] {
  1315.         set truehdr $hdr
  1316.     }
  1317.     set show 1
  1318.     foreach item $mhProfile(header-suppress) {
  1319.         if [regexp -nocase ^${item}\$ $truehdr] {
  1320.         set show 0
  1321.         break
  1322.         }
  1323.     }
  1324.     foreach item $mhProfile(header-display) {
  1325.         if [regexp -nocase ^${item}\$ $truehdr] {
  1326.         set show 1
  1327.         break
  1328.         }
  1329.     }
  1330.     if {!$show || ([string length $mimeHdr($part,hdr,$hdr)] == 0)} {
  1331.         if $inlin {
  1332.         $tkw mark set insert $hideMark
  1333.         set show 0
  1334.         } else {
  1335.         continue
  1336.         }
  1337.     }
  1338.     set start [$tkw index insert]
  1339.     $tkw insert insert [string toupper [string index $truehdr 0]]
  1340.     $tkw insert insert "[string range $truehdr 1 end]: "
  1341.     set tag [Mime_PrintEncodedHeader $tkw [MimeLabel $part headers] \
  1342.                 $mimeHdr($part,hdr,$hdr) \
  1343.                 medium r plain $mime(fontSize)]
  1344.     if [regexp -nocase date $truehdr] {
  1345.         MimeShowTime $tkw $mimeHdr($part,hdr,$hdr)
  1346.     }
  1347.     $tkw insert insert \n
  1348.     foreach key [list $truehdr [expr {$show ? "default" : "hidden"}]] {
  1349.         if [info exists msg(tag,$key)] {
  1350.         $tkw tag add hdrlook=$key $start "insert -1 char"
  1351.         if {[string length $tag] != 0} {
  1352.             $tkw tag lower hdrlook=$key $tag
  1353.         }
  1354.         break
  1355.         }
  1356.     }
  1357.     if {! $show} {
  1358.         set hideMark [$tkw index insert]
  1359.         $tkw mark set insert "end -1c"
  1360.     }
  1361.     }
  1362.     if {$inlin} {
  1363.     set mimeHdr($part,yview) $hideMark
  1364.     }
  1365.     return
  1366. }
  1367. proc MimeRedisplayHeaders {tkw part} {
  1368.     global mimeHdr
  1369.  
  1370.     $tkw configure -state normal
  1371.     set headerTag [MimeLabel $part headers]
  1372.     if ![catch {set start [$tkw index $headerTag.first]}] {
  1373.     set end [$tkw index $headerTag.last]
  1374.  
  1375.     MimeClearHigherTags $tkw $headerTag $start $end
  1376.     $tkw mark set insert $end
  1377.  
  1378.     MimeShowHeaders $tkw $part {}
  1379.  
  1380.     MimeCleanTag $tkw 1
  1381.     $tkw delete $start $end
  1382.     $tkw mark set insert end
  1383.     }
  1384.     Exmh_Status "Redisplayed headers for $part"
  1385.  
  1386.     $tkw configure -state disabled
  1387. }
  1388. proc MimeDecode {fileName name encoding text} {
  1389.     global mime
  1390.     set ok 1
  1391.     Exmh_Debug MimeDecode $fileName $name $encoding $text
  1392.     if [file exists $name] {
  1393.     if {! [FileExistsDialog $name]} {
  1394.         Exmh_Status "Save canceled"
  1395.         return 0
  1396.     }
  1397.     }
  1398.     if [catch {
  1399.     set out [open $name w 0600]
  1400.     switch -regexp -- $encoding {
  1401.         (8|7)bit {
  1402.         Exmh_Debug "cat > $name"
  1403.         exec cat $fileName >@ $out
  1404.         }
  1405.         base64 {
  1406.         if $text {
  1407.             Exmh_Debug "$mime(encode) -u -b -p > $name"
  1408.             exec $mime(encode) -u -b -p $fileName >@ $out
  1409.         } else {
  1410.             Exmh_Debug "$mime(encode) -u -b > $name"
  1411.             exec $mime(encode) -u -b $fileName >@ $out
  1412.         }
  1413.         }
  1414.         quoted-printable {
  1415.         Exmh_Debug "$mime(encode) -u -q > $name"
  1416.         exec $mime(encode) -u -q $fileName >@ $out
  1417.         }
  1418.         .*uue.* {
  1419.         Exmh_Debug "uudecode -p > $name"
  1420.         close $out
  1421.         Mime_Uudecode $fileName $name
  1422.         }
  1423.         default {
  1424.         Exmh_Debug "cat > $name"
  1425.         exec cat $fileName >@ $out
  1426.           }
  1427.     }
  1428.     catch {close $out}
  1429.     } err] {
  1430.     Exmh_Status "Decode failed: $err"
  1431.     catch {close $out}
  1432.     set ok 0
  1433.     }
  1434.     return $ok
  1435. }
  1436.  
  1437. proc Mime_ShowApplicationOctet {tkw part} {
  1438.     global mimeHdr
  1439.  
  1440.     $tkw insert insert "You have received an encoded file.\t\t"
  1441.     MimeInsertNote $tkw [MimeLabel $part part] \
  1442.            "Invoke menu with right button."
  1443.     MimeInsertInfo $tkw $part
  1444.     $tkw insert insert \n
  1445.     TextButton $tkw "Decode and Save..." \
  1446.     [list Mime_SavePiece $part $mimeHdr($part,type)]
  1447.     return 0
  1448. }
  1449. proc Mime_ShowMessageExternal {tkw part} {
  1450.     global mimeHdr mime
  1451.  
  1452.     if ![info exists mimeHdr($part,param,access-type)] {
  1453.     return [Mime_ShowDefault $tkw $part]
  1454.     }
  1455.  
  1456.     MimeInsertInfo $tkw $part
  1457.  
  1458.     if ![info exists mimeHdr($part,numParts)] {
  1459.     set fileName $mimeHdr($part,file)
  1460.     if [catch {open $fileName r} fileIO] {
  1461.         Exmh_Status "Cannot open body $fileName: $fileIO"
  1462.         return 1
  1463.     }
  1464.  
  1465.     set mimeHdr($part,numParts) \
  1466.         [MimeParseSingle $tkw $part $fileIO]
  1467.     MimeClose $fileIO
  1468.  
  1469.     if [info exists mimeHdr($part=1,file)] {
  1470.         set mimeHdr($part=1,phantom-body) \
  1471.         $mimeHdr($part=1,file)
  1472.         unset mimeHdr($part=1,file)
  1473.     }
  1474.  
  1475.     set atype [string tolower $mimeHdr($part,param,access-type)]
  1476.     set type $mimeHdr($part=1,type)
  1477.  
  1478.     if [info exists mime(accessMethod,$atype)] {
  1479.         # Special hack to not have to fetch a local-file
  1480.         if {[string compare $atype "local-file"] == 0} {
  1481.         $mime(accessMethod,$atype) $tkw $part
  1482.         } else {
  1483.         MimeMenuAdd $part command \
  1484.             -label "Get $type via $atype..." \
  1485.             -command [list MimeTransferFile $tkw $part]
  1486.         MimeMenuDelete $part Save*...
  1487.         }
  1488.     }
  1489.     } else {
  1490.     set atype [string tolower $mimeHdr($part,param,access-type)]
  1491.     set type $mimeHdr($part=1,type)
  1492.     }
  1493.     if ![info exists mime(accessMethod,$atype)] {
  1494.     MimeInsertNote $tkw [MimeLabel $part part] \
  1495.                "Use Metamail to access $type via '$atype'"
  1496.     }
  1497.  
  1498.     set color $mimeHdr($part,color)
  1499.     $tkw tag configure [MimeLabel $part part] -background \
  1500.     [MimeDarkerColor $tkw $mimeHdr($part,color)] \
  1501.     -foreground [$tkw cget -foreground]
  1502.     set mimeHdr($part=1,color) $color
  1503.  
  1504.     MimeInsertSeparator $tkw $part 6
  1505.     MimeShowPart $tkw $part=1 [MimeLabel $part part] 1
  1506.  
  1507.     return 0
  1508. }
  1509. proc MimeTransferFile {tkw part} {
  1510.     global mimeHdr mime
  1511.  
  1512.     $mime(accessMethod,[string tolower $mimeHdr($part,param,access-type)]) \
  1513.     $tkw $part
  1514.  
  1515.     MimeSetStdMenuItems $tkw $part
  1516.  
  1517.     MimeSetDisplayFlag $part
  1518.     MimeRedisplayPart $tkw $part
  1519. }
  1520. proc MimeLocalFileTransfer {tkw part} {
  1521.     global mime mimeHdr
  1522.  
  1523.     set name $mimeHdr($part,param,name)
  1524.     set dir $mimeHdr($part,param,directory)
  1525.  
  1526.     set mimeHdr($part=1,file) [file join $dir $name]
  1527. }
  1528. proc MimeFTPTransfer {tkw part} {
  1529.     global mime mimeHdr
  1530.  
  1531.     set site $mimeHdr($part,param,site)
  1532.     set directory $mimeHdr($part,param,directory)
  1533.     set theirname $mimeHdr($part,param,name)
  1534.  
  1535.     if ![string compare "URI tool" $mime(ftpMethod)] {
  1536.     busy URI_StartViewer "ftp://$site/$directory/$theirname"
  1537.     Exmh_Status "FTP request send to your WWW browser"
  1538.     return
  1539.     }
  1540.  
  1541.     set myname [Mime_TempFile $part=1]
  1542.     if [info exists mimeHdr($part,param,mode)] {
  1543.     set mode $mimeHdr($part,param,mode)
  1544.     } else {
  1545.     set mode binary
  1546.     }
  1547.     if {[string length $myname] != 0} {
  1548.     if [catch {
  1549.         case $mime(ftpMethod) {
  1550.         expect {
  1551.             Exmh_Status "ftp.expect $site ..."
  1552.             busy exec ftp.expect $site $directory $theirname $myname $mode
  1553.         }
  1554.         ftp* {
  1555.             Exmh_Status "$mime(ftpCommand) -n $site ..."
  1556.             busy MimeFTPInner $site $directory $theirname $myname $mode
  1557.         }
  1558.         metamail {
  1559.             MimeMetaMail $mimeHdr($part,hdr,content-type) \
  1560.                $mimeHdr($part,encoding) \
  1561.                $mimeHdr($part,file)
  1562.         }
  1563.         default {
  1564.             error "Unknown ftpMethod $mime(ftpMethod)"
  1565.         }
  1566.         }
  1567.     } err] {
  1568.         if [Exwin_Toplevel .ftpmsg "FTP error"] {
  1569.         Widget_Text .ftpmsg 20
  1570.         }
  1571.         .ftpmsg.t delete 1.0 end
  1572.         .ftpmsg.t insert 1.0 \
  1573. "Messages generated during FTP transfer:
  1574.  
  1575. $err
  1576. "
  1577.     } else {
  1578.         Exmh_Status "FTP transfer complete"
  1579.     }
  1580.     }
  1581.     set mimeHdr($part=1,file) $myname
  1582.     set mimeHdr($part=1,param,name) $theirname
  1583. }
  1584. proc MimeFTPInner {site directory theirname myname mode} {
  1585.     global env mime
  1586.  
  1587.     if {[string compare $mime(ftpMethod) "ftp -n"] == 0} {
  1588.     set pipe [open "|$mime(ftpCommand) -n $site " w]
  1589.     puts $pipe "user anonymous $env(USER)@"
  1590.     } else {
  1591.     set pipe [open "|$mime(ftpCommand) $site" w]
  1592.     puts $pipe anonymous
  1593.     puts $pipe $env(USER)@
  1594.     }
  1595.     puts $pipe "cd $directory"
  1596.     puts $pipe "type $mode"
  1597.     puts $pipe "get $theirname $myname"
  1598.     puts $pipe "quit"
  1599.     MimeClose $pipe
  1600. }
  1601.  
  1602. proc Mime_ShowMultipart {tkw part} {
  1603.     global mimeHdr mime
  1604.  
  1605.     set mime(stop) 0
  1606.     set mime(grab) 0    ;# Global state so there is only one grab
  1607.     set grab       0    ;# This level's state
  1608.     MimeWithDisplayHiding $tkw $part {
  1609.     if ![info exists mimeHdr($part,param,boundary)] {
  1610.         $tkw insert insert "No <boundary> parameter for multipart message\n"
  1611.         $tkw insert insert "Raw content follows...\n\n"
  1612.         return [Mime_ShowText $tkw $part]
  1613.     }
  1614.  
  1615.     Exmh_Debug "Mime_ShowMultipart $part $mimeHdr($part,type)"
  1616.  
  1617.     set numParts $mimeHdr($part,numParts)
  1618.     if {$numParts > $mime(maxSubpartsDisplayed) && !$mime(grab)} {
  1619.         global exwin
  1620.         set g $exwin(mtext).mstop
  1621.         if [winfo exists $g] {
  1622.         destroy $g
  1623.         }
  1624.         frame $g -bd 4 -relief raised
  1625.         set f [frame $g.pad -bd 20]
  1626.         set msg [Widget_Message $f msg -text "$numParts Parts" -width 200]
  1627.         Widget_AddBut $f stop STOP {set mime(stop) 1} {top padx 2 pady 2 filly}
  1628.         bind $f.stop <Any-Key> {set mime(stop) 1; Exmh_Status Stop warn}
  1629.         pack $f
  1630.         Widget_PlaceDialog $exwin(mtext) $g
  1631.         Visibility_Wait $f.stop
  1632.         focus $f.stop
  1633.         catch {grab $f.stop}
  1634.         set mime(grab) 1
  1635.         set grab 1
  1636.     }
  1637.  
  1638.     if [catch {
  1639.         for {set subpart 1} {$subpart <= $numParts} {incr subpart} {
  1640.     
  1641.         set mimeHdr($part=$subpart,color) \
  1642.             [MimeDarkerColor $tkw $mimeHdr($part,color)]
  1643.         set mimeHdr($part=$subpart,display) \
  1644.             [expr {($numParts <= $mime(maxSubpartsDisplayed)) || \
  1645.                ![regexp -nocase "^multipart|^message" \
  1646.                  $mimeHdr($part=$subpart,type)]}]
  1647.         if {$subpart != 1} {
  1648.             if [info exists msg] {
  1649.             $msg config -text "$subpart of $numParts parts"
  1650.             }
  1651.             MimeInsertSeparator $tkw $part 8
  1652.         }
  1653.         MimeShowPart $tkw $part=$subpart [MimeLabel $part part] 0
  1654.         if {$mime(grab)} {
  1655.             update;    # Allow button hit
  1656.         }
  1657.         if {$mime(stop)} {
  1658.             break
  1659.         }
  1660.         }
  1661.     } err] {
  1662.         Exmh_Status $err
  1663.     }
  1664.     }
  1665.     if {$grab} {
  1666.     catch {grab release $g.stop}
  1667.     Exmh_Focus
  1668.     destroy $g
  1669.     set mime(grab) 0
  1670.     }
  1671.     return 1
  1672. }
  1673. proc Mime_ShowMultipartParallel {tkw part} {
  1674.     global mimeHdr mime
  1675.  
  1676.     MimeWithDisplayHiding $tkw $part {
  1677.     if ![info exists mimeHdr($part,param,boundary)] {
  1678.         $tkw insert insert "No <boundary> parameter for multipart message\n"
  1679.         $tkw insert insert "Raw content follows...\n\n"
  1680.         return [Mime_ShowText $tkw $part]
  1681.     }
  1682.  
  1683.     set numParts $mimeHdr($part,numParts)
  1684.     
  1685.     for {set subpart 1} {$subpart <= $numParts} {incr subpart} {
  1686.         set mimeHdr($part=$subpart,color) \
  1687.         [MimeDarkerColor $tkw $mimeHdr($part,color)]
  1688.         set mimeHdr($part=$subpart,justDoIt) 1
  1689.         if {$subpart != 1} {
  1690.         MimeInsertSeparator $tkw $part 8
  1691.         }
  1692.         MimeShowPart $tkw $part=$subpart [MimeLabel $part part] 0
  1693.     }
  1694.     }
  1695.     return 1
  1696. }
  1697. proc Mime_ShowMultipartDigest {tkw part} {
  1698.     global mimeHdr mime
  1699.  
  1700.     MimeWithDisplayHiding $tkw $part {
  1701.     if ![info exists mimeHdr($part,param,boundary)] {
  1702.         $tkw insert insert "No <boundary> parameter for multipart message\n"
  1703.         $tkw insert insert "Raw content follows...\n\n"
  1704.         return [Mime_ShowText $tkw $part]
  1705.     }
  1706.  
  1707.     set numParts $mimeHdr($part,numParts)
  1708.     
  1709.     Exmh_Debug DIGEST with $numParts parts
  1710.     for {set subpart 1} {$subpart <= $numParts} {incr subpart} {
  1711.         Exmh_Debug digest $part $subpart 
  1712.         set mimeHdr($part=$subpart,color) \
  1713.         [MimeDarkerColor $tkw $mimeHdr($part,color)]
  1714.         set mimeHdr($part=$subpart,type) message/rfc822
  1715.         set mimeHdr($part=$subpart,display) \
  1716.         [expr {$numParts <= $mime(maxSubpartsDisplayed)}]
  1717.         if {$subpart != 1} {
  1718.         MimeInsertSeparator $tkw $part 8
  1719.         }
  1720.         MimeShowPart $tkw $part=$subpart [MimeLabel $part part] 0
  1721.     }
  1722.     }
  1723.     return 1
  1724. }
  1725. proc Mime_ShowMultipartAlternative {tkw part} {
  1726.     global mimeHdr mime
  1727.  
  1728.     if ![info exists mimeHdr($part,param,boundary)] {
  1729.     $tkw insert insert "No <boundary> parameter for multipart message\n"
  1730.     $tkw insert insert "Raw content follows...\n\n"
  1731.     return [Mime_ShowText $tkw $part]
  1732.     }
  1733.  
  1734.     set color $mimeHdr($part,color)
  1735.     $tkw tag configure [MimeLabel $part part] -background \
  1736.     [MimeDarkerColor $tkw [MimeDarkerColor $tkw $color]] \
  1737.     -foreground [$tkw cget -foreground]
  1738.  
  1739.     set numParts $mimeHdr($part,numParts)
  1740.     
  1741.     # If we can't read any parts, "display" the first one.
  1742.     set mimeHdr($part,chosenPart) 1
  1743.  
  1744.     for {set subpart 1} {$subpart <= $numParts} {incr subpart} {
  1745.     set mimeHdr($part=$subpart,color) $color
  1746.     set type $mimeHdr($part=$subpart,type)
  1747.     # Choose the last part that we understand
  1748.     foreach t [list $type [file dirname $type]] {
  1749.         if [info exists mime(showproc,$t)] {
  1750.         set mimeHdr($part,chosenPart) $subpart
  1751.         }
  1752.     }
  1753.     if [MimeCheckRule $part=$subpart ""] {
  1754.         set mimeHdr($part,chosenPart) $subpart
  1755.       }
  1756.     # Provide menu items to get to all parts
  1757.     MimeMenuAdd $part radiobutton \
  1758.           -label "Show alternative $subpart: $type" \
  1759.           -command [list busy MimeRedisplaySubpart $tkw \
  1760.                  $part] \
  1761.           -variable mimeHdr($part,chosenPart) \
  1762.           -value $subpart
  1763.     }
  1764.  
  1765.     # If we find a type we like, use that subpart instead
  1766.     # This is to support display of text/plain instead of text/html
  1767.  
  1768.     set preferred [option get . mime_alternative_prefs {}]
  1769.     set selected 0
  1770.     foreach preftype $preferred {
  1771.     for {set subpart 1} {$subpart <= $numParts} {incr subpart} {
  1772.         set type $mimeHdr($part=$subpart,type)
  1773.         if {$type == $preftype} {
  1774.         set mimeHdr($part,chosenPart) $subpart
  1775.         set selected 1
  1776.         break
  1777.         }
  1778.     }
  1779.     if {$selected != 0} {break}
  1780.     }
  1781.  
  1782.     set mimeHdr($part,priorChosenPart) \
  1783.     $mimeHdr($part,chosenPart)
  1784.  
  1785.     $tkw insert insert "There are alternative views of the following:\t"
  1786.     MimeInsertNote $tkw [MimeLabel $part part] \
  1787.            "Invoke menu with right button."
  1788.     MimeInsertSeparator $tkw $part 6
  1789.     MimeShowPart $tkw $part=$mimeHdr($part,chosenPart) \
  1790.          [MimeLabel $part part] 1
  1791.  
  1792.     return 1
  1793. }
  1794.  
  1795. proc MimeShowReportPart {tkw part overTag only reportPart} {
  1796.     global mimeHdr
  1797.  
  1798.     set partTag [MimeLabel $part part]
  1799.     if ![info exists mimeHdr($part,decode)] {
  1800.     # decode sub-parts by default, but not main body
  1801.     set mimeHdr($part,decode) [string compare $part 0=1]
  1802.     }
  1803.     MimeWithTagging $tkw $partTag $overTag \
  1804.             {-background $mimeHdr($part,color) \
  1805.              -foreground [$tkw cget -foreground]} {
  1806.     MimeSetPartVars desc displayedPart $tkw $part $partTag
  1807.     MimeSetStdMenuItems $tkw $part
  1808.     MimeShowPartHeader $tkw $part $partTag $only $reportPart $desc
  1809.     MimeShowPartBody $tkw $part
  1810.     }
  1811.     Exmh_Status $desc
  1812. }
  1813.  
  1814. proc Mime_ShowMultipartReport {tkw part} {
  1815.     global mimeHdr mime
  1816.  
  1817.     MimeWithDisplayHiding $tkw $part {
  1818.     if ![info exists mimeHdr($part,param,boundary)] {
  1819.         $tkw insert insert "No <boundary> parameter for multipart message\n"
  1820.         $tkw insert insert "Raw content follows...\n\n"
  1821.         return [Mime_ShowText $tkw $part]
  1822.     }
  1823.  
  1824.     set numParts $mimeHdr($part,numParts)
  1825.  
  1826.     if { $numParts < 2 || $numParts > 3 } {
  1827.         $tkw insert insert "Incorrect number of parts in multipart/report\n"
  1828.     }
  1829.  
  1830.     if { $numParts >= 1 } {
  1831.         set mimeHdr($part=1,color) \
  1832.         [MimeDarkerColor $tkw $mimeHdr($part,color)]
  1833.         set mimeHdr($part=1,justDoIt) 1
  1834.         MimeShowReportPart $tkw $part=1 [MimeLabel $part part] 0 \
  1835.         "Human-readable report  "
  1836.     }
  1837.  
  1838.     if { $numParts >= 2 } {
  1839.         set mimeHdr($part=2,color) \
  1840.         [MimeDarkerColor $tkw $mimeHdr($part,color)]
  1841.         set mimeHdr($part=2,justDoIt) 1
  1842.         MimeInsertSeparator $tkw $part 8
  1843.  
  1844.         if { $numParts >= 3 } {
  1845.         set mimeHdr($part=2,originalMessageEnclosed) 1
  1846.  
  1847.         if [catch {open $mimeHdr($part=3,file)} in] {
  1848.             error "Cannot read original message file"
  1849.         } else {
  1850.             while {! [eof $in]} {
  1851.             set len [gets $in line]
  1852.             if {[string match "date:*" [string tolower $line]]} {
  1853.                 set mimeHdr($part=2,originalMessageDate) \
  1854.                 [string trim [string range $line 5 end]]
  1855.             }
  1856.             }
  1857.             close $in
  1858.         }
  1859.  
  1860.         } else {
  1861.         set mimeHdr($part=2,originalMessageEnclosed) 0
  1862.         }
  1863.  
  1864.         MimeShowReportPart $tkw $part=2 [MimeLabel $part part] 0 \
  1865.         "Machine-readable report"
  1866.     }
  1867.     
  1868.     if { $numParts >= 3 } {
  1869.         set mimeHdr($part=3,color) \
  1870.         [MimeDarkerColor $tkw $mimeHdr($part,color)]
  1871.         set mimeHdr($part=3,justDoIt) 1
  1872.         MimeInsertSeparator $tkw $part 8
  1873.         MimeShowReportPart $tkw $part=3 [MimeLabel $part part] 0 \
  1874.         "Original message       "
  1875.     }
  1876.  
  1877.     for {set subpart 4} {$subpart <= $numParts} {incr subpart} {
  1878.         set mimeHdr($part=$subpart,color) \
  1879.         [MimeDarkerColor $tkw $mimeHdr($part,color)]
  1880.         set mimeHdr($part=$subpart,justDoIt) 1
  1881.         MimeInsertSeparator $tkw $part 8
  1882.         MimeShowPart $tkw $part=$subpart [MimeLabel $part part] 0
  1883.     }
  1884.     }
  1885. }
  1886.  
  1887. proc ParseReport {part reportVar} {
  1888.  
  1889.     global mimeHdr
  1890.  
  1891.     upvar $reportVar report
  1892.     set uniq 1
  1893.     set cur  " "
  1894.  
  1895.     if [catch {open $mimeHdr($part,file)} in] {
  1896.     error "Cannot read report body"
  1897.     }
  1898.     while {! [eof $in]} {
  1899.     gets $in line
  1900. Exmh_Status "Parse report: $line"
  1901.     if ![regexp {^[     ]} $line] {
  1902.         if [regexp -indices {^([^:]+):} $line match hdr] {
  1903.         set cur [string tolower [eval {string range $line} $hdr]]
  1904.         if [info exists report($cur)] {
  1905.             # Duplicate header
  1906.             set cur :$uniq:$cur
  1907.             incr uniq
  1908.         }
  1909.         set report($cur) \
  1910.             [string trim \
  1911.              [string range $line \
  1912.                   [expr [lindex $match 1]+1] end]]
  1913. Exmh_Status "  header: $cur: $report($cur)"
  1914.         }
  1915.     } elseif [regexp -indices {^[     ]+} $line match] {
  1916.         append report($cur) \n$line
  1917.     }
  1918.     }
  1919.     close $in
  1920. }
  1921.  
  1922. proc Mime_ExplainMDN {tkw part reportVar} {
  1923.     global mimeHdr mime
  1924.     upvar $reportVar report
  1925.  
  1926.     if [info exists report(disposition)] {
  1927.     $tkw insert insert \
  1928. "This report is a message disposition notification, which reports
  1929. details on how the recipient received the message.\n\n"
  1930.     MDNExplainDisposition $tkw report
  1931.     } else {
  1932.     $tkw insert insert \
  1933. "This report is a message disposition notification, which indicates that
  1934. the message probably was received by the recipient, but no further details 
  1935. are known.  There is no guarantee that the message actually was seen
  1936. or acted on by the recipient."
  1937.     }
  1938.     return 1
  1939. }
  1940.  
  1941. proc Mime_ExplainDSN {tkw part reportVar} {
  1942.     global mimeHdr mime
  1943.     upvar $reportVar report
  1944.  
  1945.     $tkw insert insert "\
  1946. This report is a delivery status notification, that reports actions taken
  1947. by the message transport system in delivering the message to the 
  1948. recipient."
  1949.  
  1950.     return 1
  1951. }
  1952.  
  1953. proc MimeChopPart {tkw part} {
  1954.     # Chop up the parts at this level if it hasn't already been done.
  1955.     global mimeHdr
  1956.  
  1957.     if ![info exists mimeHdr($part,numParts)] {
  1958.     set fileName $mimeHdr($part,file)
  1959.     if [catch {set mimeHdr($part,param,boundary)} boundary] {
  1960.         # Not a valid multpart
  1961.         Exmh_Status "Invalid MIME Multipart"
  1962.         set mimeHdr($part,content-type) text/plain
  1963.         set mimeHdr($part,numParts) 0
  1964.         return
  1965.     }
  1966.     # spaces in boundarys can cause line breaks - cc-mail trash
  1967.     regsub -all "\n *" $boundary { } boundary
  1968.     set type $mimeHdr($part,type)
  1969.     if [catch {open $fileName r} fileIO] {
  1970.         $tkw insert insert "Mime_ChopPart $fileName: $fileIO\n"
  1971.         return 0
  1972.     }
  1973.     set mimeHdr($part,numParts) \
  1974.         [MimeParseMulti $tkw $part $fileIO $boundary \
  1975.         [expr {($type == "multipart/digest") ? \
  1976.             "message/rfc822" : "text/plain"}]]
  1977.     MimeClose $fileIO
  1978.     }
  1979. }
  1980. proc MimeParseMulti {tkw part fileIO boundary defType} {
  1981.     global mimeHdr mime
  1982.  
  1983.     set subpart 0
  1984.  
  1985.     # Prolog
  1986.     while {([set numBytes [gets $fileIO line]] >= 0) &&
  1987.        ([string compare --$boundary $line] != 0) &&
  1988.        ([string compare --$boundary-- $line] != 0)} {
  1989.     if {$mime(showPrelude)} {
  1990.         $tkw insert insert $line\n
  1991.     }
  1992.     }
  1993.  
  1994.     while {($numBytes >= 0) && ([string compare --$boundary-- $line] != 0)} {
  1995.     incr subpart
  1996.     set mimeHdr($part=$subpart,file) \
  1997.         [Mime_TempFile $part=$subpart]
  1998.     set tmpFile [open $mimeHdr($part=$subpart,file) w 0600]
  1999.     catch {unset contentType}
  2000.  
  2001.     # Header
  2002.     while {([set numBytes [gets $fileIO line]] > 0) &&
  2003.            ([string compare --$boundary-- $line] != 0) &&
  2004.            ([string compare --$boundary $line] != 0) &&
  2005.            (! [regexp -- {^-*$} $line])} {
  2006.         if ![regexp {^[     ]} $line] {
  2007.         if [regexp -indices {^([^:]+):} $line match hdr] {
  2008.             set cur [string tolower \
  2009.                 [eval {string range $line} $hdr]]
  2010.             set mimeHdr($part=$subpart,hdr,$cur) \
  2011.             [string trim \
  2012.                 [string range $line \
  2013.                     [expr [lindex $match 1]+1] end]]
  2014.             lappend mimeHdr($part=$subpart,hdrs) $cur
  2015.         }
  2016.         } elseif [regexp -indices {^[     ]+} $line match] {
  2017.         if {![info exists cur] || [regexp {^[     ]+$} $line]} {
  2018.             # No header!
  2019.             puts $tmpFile $line
  2020.             break
  2021.         }
  2022.         append mimeHdr($part=$subpart,hdr,$cur) \n$line
  2023.         }
  2024.     }
  2025.     if {($numBytes >= 0) && ([string compare --$boundary-- $line] != 0)} {
  2026.         MimeMapSunHeaders $tkw $part=$subpart
  2027.         if [catch {set mimeHdr($part=$subpart,hdr,content-type)} contentType] {
  2028.         set contentType $defType
  2029.         }
  2030.         if [catch {set mimeHdr($part=$subpart,hdr,content-transfer-encoding)} encoding] {
  2031.         set encoding 7bit
  2032.         }
  2033.         set encoding [string trim [string tolower $encoding] \ \" ]
  2034.         set type [MimeHeader $part=$subpart $contentType $encoding]
  2035.  
  2036.         # Body
  2037.             set sep ""
  2038.         while {([set numBytes [gets $fileIO line]] >= 0) &&
  2039.            ([string compare --$boundary $line] != 0) &&
  2040.            ([string compare --$boundary-- $line] != 0)} {
  2041.         puts -nonewline $tmpFile $sep$line
  2042.         set sep \n
  2043.         if $mime(stop) {
  2044.             break
  2045.         }
  2046.         }
  2047.         catch {unset cur}
  2048.     }
  2049.     if ![info exists contentType] {
  2050.         # Empty body part
  2051.         incr subpart -1
  2052.     }
  2053.     close $tmpFile
  2054.     }
  2055.     return $subpart
  2056. }
  2057. proc MimeParseSingle {tkw part fileIO } {
  2058.     global mimeHdr mime miscRE msg
  2059.  
  2060.     set mimeHdr($part=1,color) $mimeHdr($part,color)
  2061.     set part $part=1
  2062.     set mimeHdr($part,hdrs) {}
  2063.     set uniq 0
  2064.  
  2065.     # Skip any blank lines or "ugly uucp-style From_ lines" at the frontend.
  2066.     while {([set numBytes [gets $fileIO line]] == 0) ||
  2067.        [regexp {^(>?From |[     ]+$)} $line]} {}
  2068.  
  2069.     # Read and parse headers
  2070.     # Display in-line if on the fastpath (first part)
  2071.     set fast [expr {[string compare $part "0=1"] == 0}]
  2072.  
  2073.     if [regexp {^([^: ]+):} $line] {
  2074.     while {$numBytes > 0} {
  2075.         if {[regexp -- {^-*$} $line]} {
  2076.         # Drafts-folder message
  2077.         break
  2078.         }
  2079.         if ![regexp {^[     ]} $line] {
  2080.         if [regexp -indices {^([^:]+):} $line match hdr] {
  2081.             set cur [string tolower \
  2082.                 [eval {string range $line} $hdr]]
  2083.             if {[lsearch $mimeHdr($part,hdrs) $cur] >= 0} {
  2084.             # Duplicate header
  2085.             set cur :$uniq:$cur
  2086.             incr uniq
  2087.             }
  2088.             set mimeHdr($part,hdr,$cur) \
  2089.                 [string trim \
  2090.                 [string range $line \
  2091.                     [expr [lindex $match 1]+1] end]]
  2092.             lappend mimeHdr($part,hdrs) $cur
  2093.         }
  2094.         } elseif [regexp -indices {^[     ]+} $line match] {
  2095.         append mimeHdr($part,hdr,$cur) \n$line
  2096.         }
  2097.         set numBytes [gets $fileIO line]
  2098.     }
  2099.     if [catch {set mimeHdr($part,hdr,content-type)} contentType] {
  2100.         set contentType text/plain
  2101.     }
  2102.     if [catch {set mimeHdr($part,hdr,content-transfer-encoding)} encoding] {
  2103.         set encoding 7bit
  2104.     }
  2105.     if {[string compare $contentType X-sun-attachment] == 0} {
  2106.         set contentType "multipart/x-sun-attachment; boundary=--------"
  2107.         set mimeHdr(0=1,hdr,mime-version) x-sun-attachment
  2108.     }
  2109.     set encoding [string trim [string tolower $encoding] \ \" ]
  2110.     set type [MimeHeader $part $contentType $encoding]
  2111.     if {[string compare $part "0=1"] == 0} {
  2112.         set mimeHdr($part,decode) \
  2113.         [expr {$mime(enabled) && 
  2114.                [info exists mimeHdr(0=1,hdr,content-type)]}]
  2115.     }
  2116.  
  2117.     } else {
  2118.     Exmh_Status "Warning - no headers" warn
  2119.     set firstLine $line
  2120.     set mimeHdr($part,type) [set type text/plain]
  2121.     set mimeHdr($part,encoding) [set encoding 8bit]
  2122.     set mimeHdr($part,params) {}
  2123.     }
  2124.     if {![info exists firstLine]} {
  2125.     set firstLinePosition [tell $fileIO]
  2126.     gets $fileIO firstLine
  2127.     if [regexp $miscRE(beginpgp) $firstLine] { set mimeHdr($part,decode) 1 }
  2128.     }
  2129.     if {$numBytes >= 0} {
  2130.     if {$fast && [string compare $type text/plain] == 0 &&
  2131.         [regexp {[78]bit} $encoding] &&
  2132.             ![regexp $miscRE(beginpgp) $firstLine]} {
  2133.         Exmh_Debug FastPath part=$part
  2134.         if $mimeHdr($part,fullHeaders) {
  2135.         MimeShowFullHeaders $tkw $part 1
  2136.         } else {
  2137.         MimeShowMinHeaders $tkw $part 1
  2138.         }
  2139.         MimeInsertSeparator $tkw $part 6
  2140.         MDNCheck $tkw
  2141.         if [info exists mimeHdr($part,param,charset)] {
  2142.         set tag [MimeSetCharset $tkw $part]
  2143.         $tkw tag remove noteTag "insert -1line"  end
  2144.         $tkw tag add $tag insert end
  2145.         if [info exists firstLinePosition] {
  2146.             seek $fileIO $firstLinePosition
  2147.         }
  2148.         Mime_SetFileEncoding $fileIO $part
  2149.         if [info exists firstLinePosition] {
  2150.             gets $fileIO firstLine
  2151.         }
  2152.         }  else {
  2153.         set tag {}
  2154.         }
  2155.         set start [$tkw index "end -1line"]
  2156.         $tkw insert end $firstLine\n $tag
  2157.         set size [expr $msg(maxsize) / 2]
  2158.         while {1} {
  2159.         $tkw insert insert [read $fileIO $size] $tag
  2160.         if {! [eof $fileIO]} {
  2161.             update
  2162.         } else {
  2163.             break
  2164.         }
  2165.         if {$mime(stop)} {
  2166.             break
  2167.         }
  2168.         }
  2169.         set end [$tkw index end]
  2170.         Msg_TextHighlight $tkw $start $end
  2171.         return 0
  2172.     } else {
  2173.         # Copy message body to a temp file.
  2174.         set mimeHdr($part,file) [Mime_TempFile $part]
  2175.         set tmpFile [open $mimeHdr($part,file) w 0600]
  2176.         if [info exists firstLine] {
  2177.         puts $tmpFile $firstLine
  2178.         }
  2179.         if [catch {
  2180.         while {1} {
  2181.             puts -nonewline $tmpFile [read $fileIO $msg(maxsize)]
  2182.             if {! [eof $fileIO]} {
  2183.             update
  2184.             } else {
  2185.             break
  2186.             }
  2187.             if {$mime(stop)} {
  2188.             break
  2189.             }
  2190.         }
  2191.         close $tmpFile
  2192.         } err] {
  2193.         catch {close $tmpFile}
  2194.         Exmh_Status $err
  2195.         File_Delete $mimeHdr($part,file)
  2196.         set mimeHdr($part,file) {}
  2197.         }
  2198.     }
  2199.     }
  2200.     return 1
  2201. }
  2202. proc MimeDarkerColor {tkw color} {
  2203.     set rgb [winfo rgb $tkw [MimeColor $tkw $color]]
  2204.     return [format "#%04x%04x%04x" \
  2205.     [expr int([lindex $rgb 0] * .95)] \
  2206.     [expr int([lindex $rgb 1] * .95)] \
  2207.     [expr int([lindex $rgb 2] * .95)]]
  2208. }
  2209. proc MimeLabel {part name} {
  2210.     regsub -all { } $name _ name
  2211.     return ==$name=$part==
  2212. }
  2213. proc MimeLabelFont {part name} {
  2214.     # create a label which may be used as either a tag or a mark.
  2215.     # Using the label in an index context doesn't work if there are
  2216.     # dashes in the name.
  2217.     regsub -all -- - ==$name=$part== = tagName
  2218.     # *'s screw up my tag raising routine
  2219.     regsub -all -- {\*} $tagName # tagName
  2220.     return $tagName
  2221. }
  2222. proc MimeMakeMenu {tkw tag part menuLabel} {
  2223.     global mimeHdr mime mimeFont
  2224.  
  2225.     set mimeHdr($part,menu) $tkw.$tag
  2226.     if [catch {menu $mimeHdr($part,menu)} err] {
  2227.     switch -regexp -- $err {
  2228.         {already exists} {
  2229.         $mimeHdr($part,menu) delete 0 999
  2230.         }
  2231.         {font.*doesn't exist} {
  2232.         if [catch {menu $mimeHdr($part,menu) -font fixed} err2] {
  2233.             Exmh_Status "MimeMakeMenu $err2"
  2234.             return
  2235.         }
  2236.         }
  2237.         default {
  2238.         Exmh_Status "MimeMakeMenu $err"
  2239.         return
  2240.         }
  2241.     }
  2242.     }
  2243.  
  2244.     $mimeHdr($part,menu) config -tearoff 0
  2245.     $mimeHdr($part,menu) configure -disabledforeground Black
  2246.     MimeMenuAdd $part command \
  2247.     -label $menuLabel \
  2248.     -state disabled \
  2249.     -font $mimeFont(title)
  2250.     MimeMenuAdd $part separator
  2251.  
  2252.     menu_bind $mimeHdr($part,menu) $tkw
  2253.     bind $tkw <ButtonPress-3> {text_menu_post %W %x %y %X %Y}
  2254.     bind $tkw <Any-ButtonRelease-3> {text_menu_unpost %W}
  2255. }
  2256. proc MimeMenuAdd {part args} {
  2257.     global mimeHdr
  2258.  
  2259.     # Only add the menu item if there isn't already something by this
  2260.     # name on the menu.     We have to do this because we may be called
  2261.     # repeatedly by redisplay code.
  2262.     set ix [lsearch $args -label]
  2263.     if {$ix >= 0} {
  2264.     incr ix
  2265.     set l [lindex $args $ix]
  2266.     set l [string range $l 0 50]
  2267.     set args [lreplace $args $ix $ix $l]
  2268.     } else {
  2269.     set l {}
  2270.     }
  2271.     if [catch {$mimeHdr($part,menu) index $l}] {
  2272.     eval $mimeHdr($part,menu) add $args
  2273.     }
  2274. }
  2275. proc MimeMenuDelete {part what} {
  2276.     global mimeHdr
  2277.  
  2278.     if [catch {$mimeHdr($part,menu) delete $what} err] {
  2279.     Exmh_Debug $err
  2280.     }
  2281. }
  2282. proc Mime_SavePiece {part type} {
  2283.     global mimeHdr mhProfile
  2284.  
  2285.     set fileName [Mime_GetUnencodedFile $part]
  2286.     if {[catch {set default $mimeHdr($part,param,name)}] && \
  2287.         [catch {set default $mimeHdr($part,hdr,content-description)}]} {
  2288.     set default ""
  2289.     }
  2290.     if {![file exists $fileName]} {
  2291.     Exmh_Status "Nothing to save!"
  2292.     return
  2293.     }
  2294.     Exmh_Status "Saving $type $fileName"
  2295.     set name [FSBox "Save $type to:" $default]
  2296.     if {$name != {}} {
  2297.     if [catch {
  2298.         exec cp $fileName $name
  2299.         exec chmod $mhProfile(msg-protect) $name
  2300.     } err] {
  2301.         Exmh_Status $err
  2302.     }
  2303.     } else {
  2304.     Exmh_Status "Not saved"
  2305.     }
  2306. }
  2307. proc Mime_PrintPiece {part type} {
  2308.     global mimeHdr print
  2309.  
  2310.     set file [Mime_GetUnencodedFile $part]
  2311.     if {[catch {set default $mimeHdr($part,param,name)}] && \
  2312.         [catch {set default $mimeHdr($part,hdr,content-description)}]} {
  2313.     set default ""
  2314.     }
  2315.     if {![file exists $file]} {
  2316.     Exmh_Status "Nothing to print!"
  2317.     return
  2318.     }
  2319.     Exmh_Status "Printing $default"
  2320.     # Because $print(cmd) embeds $file, extra levels of eval are required
  2321.     if {[catch {eval eval exec $print(cmd)} logvar]} {
  2322.     if [Exwin_Toplevel .printmsg "Print Messages"] {
  2323.         Widget_Message .printmsg msg -aspect 1500 -relief raised 
  2324.     }
  2325.     .printmsg.msg configure -text \
  2326. "Messages generated when printing your message part:
  2327.  
  2328. $logvar
  2329. "
  2330.  
  2331.     }
  2332.     Exmh_Status ok
  2333. }
  2334. proc Mime_TempFile {part} {
  2335.     global mime mimeHdr
  2336.  
  2337.     set uid 0
  2338.     while {[file exists [set fn "[Env_Tmp]/$uid.$part.[pid].exmh"]]} {
  2339.     incr uid
  2340.     }
  2341.     lappend mime(junkfiles) $fn
  2342.     return $fn
  2343. }
  2344. proc Mime_Debug { args } {
  2345.     puts stderr $args
  2346. }
  2347.  
  2348. proc Mime_PrintEncodedHeader {w overTag string weight slant fontSet size} {
  2349.     global mime
  2350.  
  2351.     set firstTag ""
  2352.     while {[string length $string] > 0} {
  2353.     if [regexp -indices {=\?([^?]*)\?(.)\?([^?]*)\?=} $string match \
  2354.         charset encoding codedstuff] {
  2355.         set x [expr [lindex $match 0] - 1]
  2356.         set leader [string range $string 0 $x]
  2357.         set charset [string tolower [eval {string range $string} $charset]]
  2358.         set encoding [string tolower [eval {string range $string} $encoding]]
  2359.         set codedstuff [eval {string range $string} $codedstuff]
  2360.         if ![regexp {^[     \r\n]*$} $string] {
  2361.         $w insert insert $leader
  2362.         }
  2363.  
  2364.         if [catch {set font [Mime_GetFont $w $weight $slant \
  2365.                           $fontSet $size $charset]}] {
  2366.         MimeInsertNote $w $overTag "Unknown charset: <$charset>" 0
  2367.         MimeWithTagging $w $overTag {} {} {
  2368.             Mime_PrintEncoded $w $encoding $codedstuff $overTag
  2369.         }
  2370.         } else {
  2371.         set tagName [MimeLabelFont $font font]
  2372.         MimeWithTagging $w $tagName $overTag {-font $font} {
  2373.             Mime_PrintEncoded $w $encoding $codedstuff $tagName
  2374.         }
  2375.         if {[string length $firstTag] == 0} {
  2376.             set firstTag $tagName
  2377.         }
  2378.         }
  2379.  
  2380.         set rest [expr [lindex $match 1]+1]
  2381.         set string [string range $string $rest end]
  2382.     } else {
  2383.         $w insert insert "$string"
  2384.         break
  2385.     }
  2386.     }
  2387.     return $firstTag
  2388. }
  2389.  
  2390. proc Mime_PrintEncoded {w encoding string tagName} {
  2391.     switch $encoding {
  2392.     "q" {
  2393.         Mime_PrintQuotedPrintable $w $string
  2394.     }
  2395.     "b" {
  2396.         Mime_PrintBase64 $w $string
  2397.     }
  2398.     default {
  2399.         MimeInsertNote $w $tagName \
  2400.         "Unknown coding of $encoding for \"$string\"" 0
  2401.     }
  2402.     }
  2403. }
  2404.  
  2405. proc Mime_PrintQuotedPrintable {w string} {
  2406.     while {[string length $string] > 0} {
  2407.     if [regexp -indices {^([^=_]*)\=(..)} $string match leader digits] {
  2408.         set leader [eval {string range $string} $leader]
  2409.         set digits [eval {string range $string} $digits]
  2410.         if [string length $leader] {
  2411.         $w insert insert $leader
  2412.         }
  2413.         scan $digits "%2x" char
  2414.         $w insert insert [format "%c" $char]
  2415.         set rest [expr [lindex $match 1]+1]
  2416.         set string [string range $string $rest end]
  2417.     } elseif [regexp -indices {^([^=_]*)_} $string match leader] {
  2418.         set leader [eval {string range $string} $leader]
  2419.         if [string length $leader] {
  2420.         $w insert insert $leader
  2421.         }
  2422.         $w insert insert " "
  2423.         set rest [expr [lindex $match 1]+1]
  2424.         set string [string range $string $rest end]
  2425.     } else {
  2426.         $w insert insert $string
  2427.         break
  2428.     }
  2429.     }
  2430. }
  2431.  
  2432. proc Mime_PrintBase64Old {w string} {
  2433.     global base64
  2434.  
  2435.     set i 0
  2436.     set end [string length $string]
  2437.     set charlist {}
  2438.     while {$i < $end} {
  2439.     set group 0
  2440.     for {set j 0} {$j < 4} {incr j} {
  2441.         set char [string index $string [expr {$i + $j}]]
  2442.         if {[string compare $char "="] != 0} {
  2443.         set bits $base64($char)
  2444.         set group [expr {$group | ($bits << ((3-$j) * 6))}]
  2445.         }
  2446.     }
  2447.     for {set j 0} {$j < 3} {incr j} {
  2448.         set byte [expr {($group >> ((2-$j) * 8)) & 255}]
  2449. #        $w insert insert [format "%c" $byte]
  2450.         lappend charlist [format "%c" $byte]
  2451.     }
  2452.     set i [expr $i+4]
  2453.     }
  2454.     $w insert insert [join $charlist ""]
  2455. }
  2456. proc Mime_PrintBase64 {w string} {
  2457.     global base64
  2458.  
  2459.     set output {}
  2460.     set group 0
  2461.     set j 18
  2462.     foreach char [split $string {}] {
  2463.     if [string compare $char "="] {
  2464.         set bits $base64($char)
  2465.         set group [expr {$group | ($bits << $j)}]
  2466.     }
  2467.  
  2468.     if {[incr j -6] < 0} {
  2469.         scan [format %06x $group] %2x%2x%2x a b c
  2470.         append output [format %c%c%c $a $b $c]
  2471.         set group 0
  2472.         set j 18
  2473.     }
  2474.     }
  2475.     $w insert insert $output
  2476. }
  2477.  
  2478.  
  2479. proc MimeInsertNote {w overTag text {newline 1}} {
  2480.     global mime mimeFont
  2481.     MimeWithTagging $w noteTag $overTag \
  2482.             {-font $mimeFont(note)} {
  2483.     $w insert insert "($text)"
  2484.     if $newline {
  2485.         $w insert insert \n
  2486.     }
  2487.     }
  2488. }
  2489. proc MimeWithTagging {tkw tag overTag configuration body} {
  2490.     if ![regexp $tag [$tkw tag names]] {
  2491.     # Create the tag, but don't mark anything with it.
  2492.     $tkw tag add $tag end
  2493.     # Push it down below everything else
  2494.     $tkw tag lower $tag
  2495.     }
  2496.     # If the tag is too low, bring it up as far as we want it, but no
  2497.     # farther.
  2498.     if {$overTag != {}} {
  2499.     MimeRaiseTag $tkw $tag $overTag
  2500.     }
  2501.     if {[string length $configuration] != 0} {
  2502.     if [catch {uplevel [list $tkw tag configure $tag] $configuration} err] {
  2503.         set ix [lsearch $configuration -font]
  2504.         if {$ix >= 0} {
  2505.         set configuration [lreplace $configuration $ix [expr $ix+1] -font fixed]
  2506.         }
  2507.         uplevel [list $tkw tag configure $tag] $configuration
  2508.     }
  2509.     }
  2510.     MimeCleanTag $tkw
  2511.     set start [$tkw index insert]
  2512.  
  2513.     if [catch {uplevel $body} err] {
  2514.     Exmh_Status $err
  2515.     }
  2516.  
  2517.     MimeRememberTag $tkw $tag
  2518.     $tkw tag add $tag $start insert
  2519. }
  2520. proc MimeRememberTag {w tag {place insert}} {
  2521.     global mimeTagStack mimeLastPoint
  2522.  
  2523.     MimeCleanTag $w 0 $place
  2524.     lappend mimeTagStack $tag
  2525.     set mimeLastPoint [$w index $place]
  2526. }
  2527. proc MimeCleanTag {w {nomatterwhat 0} {place insert}} {
  2528.     global mimeTagStack mimeLastPoint
  2529.  
  2530.     if [info exists mimeLastPoint] {
  2531.     if {[string compare $mimeLastPoint [$w index $place]] == 0} {
  2532.         # I sure hope another MimeCleanTag is called later
  2533.     } else {
  2534.         if [info exists mimeTagStack] {
  2535.         foreach tag $mimeTagStack {
  2536.             $w tag remove $tag $mimeLastPoint $place
  2537.         }
  2538.         unset mimeTagStack
  2539.         }
  2540.         unset mimeLastPoint
  2541.     }
  2542.     }
  2543.     if {$nomatterwhat} {
  2544.     catch {unset mimeLastPoint}
  2545.     catch {unset mimeTagStack}
  2546.     }
  2547. }
  2548. proc MimeRaiseTag {w tag {overTag {}}} {
  2549.     if {[string length $overTag] == 0} {
  2550.     $w tag raise $tag
  2551.     } elseif [regexp "${tag}.*${overTag}" [$w tag names]] {
  2552. Exmh_Debug "RaiseTag $tag $overTag"
  2553.     $w tag raise $tag $overTag
  2554.     }
  2555. }
  2556. proc MimeInsertSeparator {tkw part width} {
  2557.     global mimeHdr mime
  2558.  
  2559.     if [$tkw compare insert != "insert linestart"] {
  2560.        $tkw insert insert "\n"
  2561.     }
  2562.     if {$mime(showSeparator)} {
  2563.     set looks {-relief sunken \
  2564.       -borderwidth 2 \
  2565.       -font -*-*-*-*-*-*-$width-*-*-*-*-*-iso8859-* \
  2566.       -background $mimeHdr($part,color)}
  2567.     set sepLabel [MimeLabel $width separator]
  2568.     MimeWithTagging $tkw $sepLabel [MimeLabel $part part] $looks {
  2569.         $tkw insert insert \n
  2570.     }
  2571.     } else {
  2572.     $tkw insert insert \n
  2573.     }
  2574. }
  2575. proc MimeClearHigherTags {w tag start end} {
  2576.     set tagList [$w tag names]
  2577.     regexp -indices "${tag}(.*)" $tagList match tagsOver
  2578.     set tagsOver [eval {string range $tagList} $tagsOver]
  2579.     foreach tag $tagsOver {
  2580.     $w tag remove $tag $start $end
  2581.     }
  2582. }
  2583. proc Mime_GetFont {w weight slant fontSet size charset} {
  2584.     global mime
  2585.     # weight = {bold medium}
  2586.     # slant = {i r}
  2587.     # fontSet = {plain title fixed proportional}
  2588.     # size = pts*10
  2589.     # charset = any valid mime charset
  2590.  
  2591.     if {[string match medium-r-plain-$mime(fontSize)-us-ascii \
  2592.         $weight-$slant-$fontSet-$size-$charset] || \
  2593.         [string match medium-r-plain-$mime(fontSize)-iso-8859-1 \
  2594.         $weight-$slant-$fontSet-$size-$charset]} {
  2595.     # Special case the most common situation
  2596.     if ![info exists mime(defaultFont)] {
  2597.         set mime(defaultFont) [option get $w font Font]
  2598.         if {[string length $mime(defaultFont)] == 0} {
  2599.         set mime(defaultFont) fixed
  2600.         }
  2601.     }
  2602.     return $mime(defaultFont)
  2603.     }
  2604.     if [regexp {^fixed$|^plain$} $fontSet] {
  2605.     set spacing "*"
  2606.     # someone tell me the difference between "m" and "c"
  2607.     } else {
  2608. #    set spacing "p"
  2609.     set spacing "*"
  2610.     }
  2611.     if {[info exists mime(registry,$charset)] &&
  2612.     ($mime(registry,$charset) != {})} {
  2613.     set registry $mime(registry,$charset)
  2614.     } else {
  2615.     set registry "iso8859"
  2616.     }
  2617.     if {[info exists mime(encoding,$charset)] &&
  2618.     ($mime(encoding,$charset) != {})} {
  2619.     set encoding $mime(encoding,$charset)
  2620.     } else {
  2621.     set encoding "*"
  2622.     }
  2623.  
  2624.     # Let's try and find a working font
  2625.     set i 1
  2626.     set family $mime(family,$charset,$fontSet,$i)
  2627.     set size [string trim $size]
  2628.  
  2629.     set font "-*-$family-$weight-$slant-*-*-*-$size-*-*-$spacing-*-$registry-$encoding"
  2630.     $w tag add dummyTag end
  2631.     while {[catch {$w tag configure dummyTag -font $font} err]} {
  2632.     # That one wasn't any good; let's look for another one
  2633.     incr i
  2634.  
  2635.     if [catch {set family $mime(family,$charset,$fontSet,$i)}] {
  2636.         # No entry?     Oh well, at least this will be the right size
  2637.         # and will have the right encoding.  If it has a problem,
  2638.         # we want to let the problem be handled outside this
  2639.         # routine.
  2640.         return "-*-*-*-*-*-*-*-$size-*-*-*-*-$registry-$encoding"
  2641.     } else {
  2642.         set font "-*-$family-$weight-$slant-*-*-*-$size-*-*-$spacing-*-$registry-$encoding"
  2643.     }
  2644.     }
  2645.     return $font
  2646. }
  2647.  
  2648. proc MimeGetRule {part method atribVar \
  2649.           {f_multipart_filenames {}} {m_multipart_filenames {}}} {
  2650.     upvar $atribVar atrib
  2651.     global mimeHdr
  2652.  
  2653.     foreach key $mimeHdr($part,params) {
  2654.     set contentParams($key) $mimeHdr($part,param,$key)
  2655.     }
  2656.     mailcap_getrule $mimeHdr($part,type) contentParams $method \
  2657.     atrib [Mime_GetUnencodedFile $part] $f_multipart_filenames \
  2658.     $m_multipart_filenames
  2659. }
  2660.  
  2661. proc MimeGetOrigFile {part} {
  2662.     global mimeHdr
  2663.  
  2664.     if ![info exists mimeHdr($part,origFile)] {
  2665.     Mime_GetUnencodedFile $part
  2666.     }
  2667.     return $mimeHdr($part,origFile)
  2668. }
  2669. proc MimeCheckRule {part method} {
  2670.     global mimeHdr
  2671.  
  2672.     if ![info exists mimeHdr($part,type)] {
  2673.     return 0
  2674.     }
  2675.     mailcap_checkrule $mimeHdr($part,type) contentParams $method
  2676. }
  2677. proc MimeMailcapView { part subparts } {
  2678.     global mimeHdr
  2679.     if [catch {MimeGetRule $part "" atrib $subparts} rule] {
  2680.     Exmh_Status $rule
  2681.     return
  2682.     }
  2683.     Exmh_Status $rule
  2684.     if [catch {
  2685.     if [info exists atrib(needsterminal)] {
  2686.         exec xterm -e sh -c $rule &
  2687.     } else {
  2688.         exec sh -c $rule &
  2689.     }
  2690.     } err] {
  2691.     Exmh_Status $err warn
  2692.     }
  2693. }
  2694. proc MimeMailcapPrint { part subparts } {
  2695.     global mimeHdr
  2696.     if [catch {MimeGetRule $part print atrib $subparts} rule] {
  2697.     Exmh_Status $rule
  2698.     return
  2699.     } else {
  2700.     Exmh_Status Printing...
  2701.     if [catch {exec sh -c $rule} err] {
  2702.         Exmh_Status $err warn
  2703.     }
  2704.     }
  2705. }
  2706. proc Mime_ShowAudio { tkw part } {
  2707.     global mimeHdr
  2708.     TextButton $tkw "Play attached audio" [list MimeShowAudioNow $tkw $part]
  2709.     $tkw insert insert \n\n
  2710.     TextButton $tkw "Save audio file" [list Mime_SavePiece $part $mimeHdr($part,type)]
  2711.     $tkw insert insert \n
  2712. }
  2713. proc MimeShowAudioNow { tkw part } {
  2714.     global mimeHdr mime
  2715.     Mime_GetUnencodedFile $part
  2716.     if [catch {MimeGetRule $part "" atrib} audioCommand] {
  2717.     Exmh_Status $audioCommand
  2718.     } else { 
  2719.     Exmh_Status $audioCommand
  2720.     exec sh -c $audioCommand > /dev/null &
  2721.     }
  2722. }
  2723.  
  2724. proc Mime_Uudecode { infile outfile } {
  2725.     set tmpfile [Env_Tmp]/exmh.uud.[file tail $infile].[pid]
  2726.     if [catch {open $tmpfile w 0600} out] {
  2727.     Exmh_Status $out
  2728.     } else {
  2729.     if [catch {open $infile} in] {
  2730.         Exmh_Status $in
  2731.         close $out
  2732.     } else {
  2733.         set print 0
  2734.         while {[gets $in line] >= 0} {
  2735.         if [regexp {begin ([0-9]+) } $line x perm] {
  2736.             puts $out "begin $perm $outfile"
  2737.             set print 1
  2738.         } elseif {$print} {
  2739.             puts $out $line
  2740.         }
  2741.         }
  2742.         close $out
  2743.         close $in
  2744.         Exmh_Status "uudecode [file tail $infile] > $outfile"
  2745.         if [catch {exec uudecode < $tmpfile} err] {
  2746.         Exmh_Status $err error
  2747.         }
  2748.     }
  2749.     File_Delete $tmpfile
  2750.     }
  2751. }
  2752.  
  2753. proc Mime_EudoraFilename {name} {
  2754.     set i [string last "/" $name]
  2755.     if {$i > -1} {
  2756.     set name [string range $name [expr $i + 1] end]
  2757.     }
  2758.     regsub -all {[^A-Za-z0-9_!#$&().~{}-]} $name "_" name
  2759.     set name [string toupper $name]
  2760.     set bits [split $name .]
  2761.     if {[llength $bits] == 1} {
  2762.     return [format "%.8s" $name]
  2763.     }
  2764.     set firstbit [lindex $bits 0]
  2765.     set bits [lrange $bits 1 end]
  2766.     while {[string length $firstbit] < 8 && [llength $bits] > 1} {
  2767.     append firstbit "_"
  2768.     append firstbit [lindex $bits 0]
  2769.     set bits [lrange $bits 1 end]
  2770.     }
  2771.     set lastbit [lindex $bits end]
  2772.     return [format "%.8s.%.3s" $firstbit $lastbit]
  2773. }
  2774.  
  2775. proc Mime_MakeBoundary { end } {
  2776.  
  2777.     # Old boundary was made by
  2778.     # regsub -all "\[ \x7f-\xff\]" [exec date] _ date
  2779.     # This way works at least with GNU date.
  2780.  
  2781.     regsub -all {[^0-9]|[0-9][0-9][0-9][0-9]} [exec date] {} boundary
  2782.     regsub {^0*} $boundary {} boundary    ;# No octal interpretation, please
  2783.     set boundary [expr $boundary*[pid]]
  2784.     return "==_Exmh_$boundary$end"
  2785. }
  2786. proc Mime_Magic { fileName } {
  2787.     global exmh env
  2788.     Exmh_Debug Mime_Magic $fileName
  2789.  
  2790.     foreach m { "-m $exmh(userLibrary)/.magic" \
  2791.      "-m $exmh(library)/local.magic" ""} {
  2792.     if [catch {eval exec file $m $fileName} result] {
  2793.         continue
  2794.     }
  2795.  
  2796.     set result [string trim [lindex [split $result :] 1]] 
  2797.  
  2798.     foreach res { magic_u magic_l magic_ } {
  2799.         set contentType [option get . $res$result {}]
  2800.         if [string length $contentType] {
  2801.         return $contentType
  2802.         }
  2803.     }
  2804.     }
  2805.  
  2806.     return
  2807. }
  2808. proc Mime_ShowXApp { tkw part } {
  2809.     global mimeHdr
  2810.     Exmh_Debug Mime_ShowXApp $part
  2811.  
  2812.     set descr [Mime_TypeDescr $part]
  2813.     if [MimeCheckRule $part ""] {
  2814.     $tkw insert insert \n
  2815.     TextButton $tkw "Open ${descr}..." [list MimeMailcapView $part ""]
  2816.     }
  2817.     if [MimeCheckRule $part "print"] {
  2818.     $tkw insert insert "  "
  2819.     TextButton $tkw "Print" [list MimeMailcapPrint $part ""]
  2820.     }
  2821.     $tkw insert insert "  "
  2822.     TextButton $tkw "Save..." \
  2823.      [list Mime_SavePiece $part $mimeHdr($part,type)]
  2824.     $tkw insert insert \n
  2825. }
  2826.